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INTRODUCTION 


The  Infrasonic  observatory  at  Windless  Bight,  Antarctica  was 
operated  continuously  during  the  period  of  1  October  1981  to  30 
September  1982  as  covered  by  this  report.  The  infrasonic  micro¬ 
phone  outputs  from  a  four  sensor  long  period  (10  to  100  sec)  array 
and  a  three  sensor  short  period  (1  to  10  sec)  array  were  digitized 
(at  1  Hz  and  4  Hz  respecti vely) ,  recorded  and  analyzed  in  real-time 
by  the  digital  data  acquisition  and  analysis  system  as  described  by 
Spell  et  al.,  in  our  progress  report  GIR  82-1  entitled:  Antarctic 
Digital  Infrasonic  System  Upqrade".  Analogue  chart  and  slow  speed 
magnetic  tape  data  were  also  recorded  for  backup  purposes 

The  diaital  magnetic  taoes  for  the  period  nf  this  report  are 
archived  at  the  Geophysical  Institute  of  the  University  of  Alaska 
beqinninq  with  tape  M81-3F,  2319  -  24  September,  1981  to  1228Z  - 
1  October  1981  to  tape  M81-51,  051 7Z  -  26  December  1981  to  08O7Z  - 
1  Janaury  1982,  for  1981  and  for  1982  beginning  with  tape  M82-1  081 5Z  - 
1  January  1982  to  2036Z  -  7  January  1982  to  tape  M82-47,  0328  26  September 
1982  to  0155Z  2  October  1982.  Infrasonic  summary  reports  of  all  signals 
with  correlation  coeffic  ent  greater  than  0.50  have  been  sent  from 
Antarctica  to  the  Geophysical  Institute  by  telex  for  each  digital  tape 
beginning  with  M82-2  0459Z  4  February  1982  to  0134Z  10  February  1982. 
Copies  of  these  infrasonic  signal  reports  for  each  digital  tape  have 
been  sent  to  Mr.  William  J.  Best  at  AFOSR/NP  at  Bolling  Air  Force  Base. 

After  Initial  electrical  noise  Interference  problems  were  corrected 
at  the  equipment  building  in  McMurdo  station  in  early  February  1982  there 


was  no  significant  data  loss  for  the  infrasonic  system.  During  the 
winter  night  the  Aurora  microphone  oscillator  failed  out  in  Windless 
Bight.  The  winter-over  operator,  Bruce  McKibben,  made  a  trip  out  to 
the  microphone  array  by  tracked  vehicle  on  July  17  to  replace  the 
faulty  oscillator  and  recalibrated  the  Aurora  microphone. 

During  the  winter  night  period  in  Antarctica,  Bruce  McKibben, 
adapted  the  off-line  analysis  and  filtering  software  that  had  been 
developed  at  the  Geophysical  Institute  on  a  large  virtual  memory 
computer  (the  VAX  1778)  for  use  on  a  much  smaller  and  slower  computer 
the  PDP  11/03  that  is  used  in  our  system  at  McMurdo  station.  This  off¬ 
line  analysis  software  is  reproduced  in  section  III  of  this  report. 

Training  of  the  new  winter-over  operator,  Kathleen  Driscoll,  began 
in  July  1982  at  the  Geophysical  Institute  and  continued  in  Antarctica 
under  the  guidance  of  Mr.  McKibben  on  ;ite  through  November  17th  when 
he  left  McMurdo  station  for  home.  Kathleen  Driscoll  is  an  electronic 
technician  with  12  years  experience  at  the  University  of  Alaska  and  at 
remote  sites  in  the  Canadian  arctic. 

In  Section  1  of  this  report,  Jefferson  Collier,  a  graduate  student 
working  on  the  analysis  of  Antarctic  infrasonic  data,  describes  the 
results  of  the  analysis  f'  ;,icrobarom  data  from  the  short  period  micro¬ 
phone  array  at  Windless  Bight  for  all  1981  data.  Mr.  Collier  is  support¬ 
ed  by  NSF/DPP  under  grant  number  DPP  8120794  for  the  analysis  of  Antarctic 
microbarom  data. 

In  Section  II,  Dr.  John  Olson  describes  the  results  of  his  research 
on  infrasonic  data  analysis  as  presented  at  the  European  Geophysical 
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Society  meeting  at  Leeds,  England  in  August  1982  at  a  special  symposium 
on  the  "Filterina  Analysis  in  Geophysics"  that  Or.  Olson  was  asked  to 
chair  because  of  his  extensive  contributions  in  this  field.  His  paper 
as  herein  reproduced  is  titled:  "Signal  Detection  in  Scalar  Arrays: 
Application  of  Adaptive,  Pure-State  Filters  to  Infrasonlc  Array  Data". 

Looistlcal  support  for  the  Antarctic  infrasonics  program  has  been 
given  by  the  Oivlsion  of  Polar  Programs  of  National  Science  Foundation 
under  a  three  year  grant  number  DPP  81-21689. 
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SECTION  I  MICROBAROM  ANALYSIS 


1 .  INTRODUCTION 

Infrasonlc  waves  from  marine  storms  have  been  recorded  at  Windless 
Bight,  Antarctica  since  September  1980.  These  waves,  commonly  called 
mlcrobaroms,  have  characteristic  periods  of  3-8  seconds,  amplitudes  of 
O.l  to  10  microbars  l dyne /cm)  and  are  generated  by  standing  waves  in 
areas  of  Intense  marine  weather  {Postmentier,  1967).  This  report  will 
deal  with  the  analysis  of  mlcrobaroms  recorded  during  1981. 

During  1981  256  days  of  continuous  digital  Infrasonic  data  was 
recorded  onto  nine-track  maqnetic  tape  usinq  a  system  described  by  Spell 
and  Wilson  (1980).  The  tapes  were  later  analyzed  using  a  VAX  H/780 
computer  uslno  digital  data  analysis  methods  including  a  data-adaptive 
pure  state  filter  or  pure  filter  (Samson  and  Olson,  1981).  The  use  of 
digital  system  alone  has  given  a  large  increase  in  the  number  of  coherent 
signals  detected.  The  use  of  the  pure  filter  enables  us  to  detect  co¬ 
herent  signals  16  db  below  the  ambient  wind  noise  level.  This  has  result¬ 
ed  in  a  further  8-fold  increase  in  the  number  of  coherent  signals  detected. 

There  are  four  areas  near  Windless  Bight  that  generate  microbaroms, 
the  Ross  Sea,  the  Bellingshausen  Sea,  the  Weddell  Sea  and  the  South 
Indian  Ocean  (see  Figure  1).  Of  these  four  areas,  the  Ross  Sea  and  the 
Bellingshausen  Sea  were  the  most  dominant.  We  detected  mlcrobaroms  from 
the  Ross  Sea  area  primarily  in  the  austral  summer,  while  microbaroms  from 
the  Bellingshausen  Sea  were  detected  primarily  in  the  austral  winter  (all 
seasons  referred  to  will  be  austral  seasons).  The  absence  of  mlcrobarom 
signals  from  the  Ross  Sea  In  the  winter  can  be  related  to  the  sea  Ice 
cover  of  the  Ross  Sea.  The  mlcrobaroms  detected  from  the  Bellingshausen 
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Sea  seem  to  have  been  generated  by  large  storms  that  are  not  present 
during  the  summer.  The  microbaroms  detected  from  the  Weddell  Sea  and 
the  southeast  Indian  Ocean  seemed  to  be  generated  by  large  individual 
storms  that  are  not  regular  features  of  those  areas. 

From  the  variations  in  the  average  trace  velocity  as  a  function  of 
azimuth  of  arrival  of  the  incoming  microbarom  signals  we  can  estimate  the 
yearly  and  seasonal  variations  of  the  stratospheric  winds  over  Windless 
Bight.  Hourly  variations  in  the  average  trace  velocity  from  the  Ross  Sea 
in  the  summer  indicates  the  presence  of  a  24-hour  component  tidal  wind  in 
the  stratosphere  over  Windless  Bight. 

2.  PROCEDURE 

The  infrasonic  data  was  collected  using  a  three  element,  capacitor 
microphone  array  with  intra-microphone  spacing  of  approximately  one  half 
the  expected  wavelength  of  microbaroms  (1800  m).  Daniels  type  noise  re¬ 
ducing  pipes  were  used  to  suppress  wind  noise  for  each  microphone  in  the 
array  (Daniels,  1959).  The  signals  were  converted  into  4096  discrete 
levels  every  25  seconds  and  recorded  on  nine-track  magnetic  tape  in  two 
minute  data  blocks.  The  data  was  later  analyzed  on  a  VAX  11/780  computer. 
Cross-correlations  were  performed  between  all  station  pairs  to  estimate 
the  time  It  takes  a  signal  to  propagate  between  each  microphone  pair.  The 
horizontal  trace  velocity  (local  sound  speed  divided  by  the  sin  of  the 
angle  between  wave  normal  and  vertical)  and  azimuth  of  arrival  were  calcu¬ 
lated  usino  a  least-sauares  estimator  (McGowan  and  Flinn,  1970).  The  two 
minute  data  blocks  were  then  pure  filtered  and  the  time  domain  analysis 
was  repeated  to  obtain  a  new  estimate  of  the  trace  velocity  and  azimuth 
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of  arrival.  The  coherence  between  slpnals  is  judged  by  calculating  the 
cross-correlation  coefficients  between  all  si  anal  pairs.  A  si  anal  was 
judged  to  be  a  coherent  wave  if  all  correlation  coefficients  were  Great¬ 
er  than  .f. 

3 .  THEORY 

If  we  assume  a  horizontally  stratified  atmosphere  then  Spell's 
law  of  sound  is  given  by, 

c/$in<|>  +  W  »  Vj  =  constant 

where  c,  <J>,  W,  Vy  are  the  speed  of  sound,  the  angle  between  vertical 
and  wave  normal,  the  horizontal  component  of  wind  in  the  direction  of 
wave  propagation  and  the  measured  horizontal  trace  velocity,  respecti vely. 
At  the  reflection  layer  $  =  90°  so 

Vr  =  Cr  +  Wr 

where  the  subscript  r  denotes  quantities  at  the  reflection  layer.  If  we 
assume  that  the  winds  at  the  reflection  layer  are  constant  over  the  area 
of  microbarom  reflection  then  the  trace  velocity  as  a  function  of  azimuth 
is  given  by 

V(4>)  =  Cr  +  Wcos  Um) 

where  <}»  and  <frm  are  the  azimuth  from  which  the  wave  is  propagating  and 
the  azimuth  from  which  the  wind  is  flowing.  iTdenotes  the  magnitude  of  W. 

A  sound  channel  is  created  when  the  speed  of  sound  in  the  upper 
atmosphere  excedes  the  speed  of  sound  on  the  surface.  There  are  two  sound 


channels  in  the  upper  atmosphere  (Diamond,  1963)  in  the  upper  stratosphere 
around  50  km  and  in  the  lower  thermosphere  around  110  km.  Donn  and  Rind 
(1972)  showed  that  for  microbaroms  reflecting  in  the  lower  thermosphere 
the  amplitudes  of  the  microbarom  signals  exhibit  a  strong  semidiurnal 
fluctuation  due  to  the  presence  of  the  semidiurnal  tidal  wind  in  the 
lower  thermosphere.  Microbaroms  reflecting  in  the  thermosphere  suffer 
increasing  energy  dissipation  with  height.  The  semidiurnal  tidal  wind 
will  cause  the  reflection  level  of  microbaroms  to  increase  or  decrease 
thus  GatrST?fg»>sj)ore  or  less  wave  attenuation.  However,  when  microbaroms 
/"^reflect  at  a  lower  level  in  the  stratosphere  there  is  little  periodic 
amplitude  variation.  This  difference  in  microbarom  amplitude  variation 
characteristics  will  allow  us  to  tell  whether  the  microbaroms  are  reflect¬ 
ing  in  the  stratosphere  or  in  the  lower  thermosphere. 

4.  TEMPERATURE  AND  WIND  OVER  ANTARCTICA 

In  the  last  section  we  showed  that  the  propagation  of  microbaroms  is 
dependent  upon  the  vertical  temperature-wind  profile  in  the  upper 
atmosphere.  Figure  2a,  b  shows  the  CIRA  1966  model  of  atmospheric 
temperature  as  a  function  of  height  and  latitude  for  January  or  July  and 
April  or  October.  We  will  use  these  months  to  represent  the  four  seasons 
winter  and  October-austral  sprina),  so  the  maximum  temperatures  in  the 
stratosphere  over  Antarctica  for  summer,  fall,  winter,  and  spring  are 
290°-30(V»,  2Bn°-2908,  250°-260°,  and  270°-2B08  (in  degree  kelvin)  respect¬ 
ively.  From  sea  ice  maps  (Figure  3)  and  surface  isotherm  maps  for  summer 
and  winter  (Figure  4a,  b)  we  can  see  that  the  temperature  of  the  surface 
of  the  antarctic  oceans  is  around  273°K.  Therefore  in  the  spring,  summer, 
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and  fall  there  can  be  a  stratospheric  sound  channel  due  solely  to 
temperature  differences  between  the  surface  and  the  stratosphere.  To 
further  understand  the  propagation  of  microbaroms  we  must  look  at  the 
vertical  wind  structure. 

f  In  the  thermosphere  the  semidiurnal  tidal  wind  will  cause  a  12-hour 

variation  in  the  amplitudes  of  the  microbaroms  that  reflect  in  the  thermo¬ 
sphere.  In  the  stratosphere  we  must  examine  the  effects  of  the  prevailing 

,  wind,  the  diurnal  tidal  wind  and  the  semidiurnal  wind  on  microbarom  propa- 

qation.  Figure  5a,  b  shows  the  1966  CIRA  model  of  zonal  winds  as  a 
function  of  heioht  and  latitude  for  January  or  July  and  April  or  October. 

f  We  again  make  the  approximation  that  these  months  represent  each  of  the 

four  seasons.  In  summer  (January)  there  are  easterly  winds  of  10  to  20 
meters  per  second  in  the  stratosphere  as  shown  in  Fiqure  5a.  In  fall 

•  (April)  winter  (July)  and  spring  (October)  there  are  westerly  winds  of 
0  to  20  meters  per  second.  These  stratospheric  winds  together  with  the 
seasonal  variations  in  the  temperature  profile  of  the  stratosphere  will 
determine  when  there  is  a  sound  channel  in  the  stratosphere.  In  the 
summer  there  should  be  a  sound  channel  in  the  stratosphere  except  for 
sound  waves  traveling  from  west  to  east.  In  spring  and  fall  there  should 

t  be  a  stratospheric  sound  channel  except  for  waves  propagating  from  east 

to  west.  During  the  winter  there  is  a  sound  channel  in  the  stratosphere 
for  waves  propagating  from  west  to  east  only. 

♦  An  obvious  drawback  to  the  CIRA  1966  model  is  the  lack  of  information 
on  the  meridional  component  of  the  stratosphere  winds.  Figure  6  shows 
zonal  and  meridional  winds  derived  from  rocketsonde  data  from  McMurdo, 
Antarctica  (1Q62).  As  can  be  seen  there  is  a  strono  component  meridional 
fl  ow. 
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The  amplitude  and  phase  of  the  diurnal  tidal  wind  as  a  function 
of  height  and  latitude  as  given  by  Chapman  and  Lindzen  (1970)  is  shown 
in  Figure  7a.  b.  The  amplitude  of  the  diurnal  wind  at  50  km  for  75  South 
latitude  is  around  5  meters  per  second  with  a  maximum  southerly  wind  at 
0000  local  time  with  nearly  constant  phase  as  a  function  of  height.  The 
amplitude  and  phase  of  the  semidiurnal  tide  as  aiven  by  Chapman  and 
Lindzen  (1970)  is  shown  in  Figure  8a,  b.  The  amplitude  of  the  semidurnal 
wind  at  50  km  altitude  is  around  2-3  meters  Der  second. 

5.  RESULTS 

The  distribution  of  number  of  signals  as  a  function  of  azimuth  of 
arrival  for  each  season  during  1981  is  shown  in  Figure  9a,  b,  c,  d.  From 
these  distributions  we  can  see  that  there  are  four  dominant  source  areas 
for  microbaroms  observed  near  Windless  Bight  (see  Figure  1),  the  Ross  Sea 
(0°  -  60°),  the  Bellingshausen  Sea  (85°  -  160°),  the  Weddell  Sea  (160°  - 
200°)  and  the  southeast  Indian  Ocean  (300°  -  360°).  In  the  summer  we  re¬ 
ceived  signals  mainly  from  the  Ross  Sea  and  the  southeast  Indian  Ocean,  in 
the  fall  from  all  four  areas,  in  the  winter  mainly  from  the  Bellingshausen 
Sea,  and  in  the  spring  from  all  but  the  southeast  Indian  Ocean. 

The  microbaroms  from  the  Weddell  sea  area  were  received  primarily 
during  the  second  week  of  March  and  the  last  two  weeks  of  September.  The 
lack  of  si  anal  s  during  the  rest  of  the  year  cannot  be  explained  by  the 
stratospheric  zonal  wind  patterns  given  in  Section  4.  As  can  be  seen  in 
Figure  1  the  propagation  path  for  microbaroms  from  the  Weddell  Sea  to 
Windless  Bight  is  perpendicul ar  to  zonal  winds.  Since  transverse  wind 
should  not  effect  the  sound  channel  this  leads  to  the  conclusion  that  the 
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microbaroms  from  Weddell  Sea  were  generated  by  large  storms  that  are  not 
usually  present  in  that  area.  Also,  as  we  will  show  later  our  data  sug¬ 
gests  that  there  is  a  strong  meridional  wind  flowing  from  Windless  Bight 
towards  the  Weddell  Sea.  A  strong  stratospheric  wind  flowing  from 
Windless  Bight  towards  the  Weddell  Sea  would  eliminate  the  stratospheric 
sound  channel  from  that  direction.  Without  a  stratospheric  sound  channel, 
microbaroms  would  propagate  into  the  thermosphere  and  suffer  energy  dis¬ 
sipation  and  then  only  if  the  initial  amplitude  of  the  microbaroms  was  very 
high  could  they  be  detected  at  Windless  Bight. 

The  microbaroms  from  the  southeast  Indian  Ocean  were  received  during 
five  different  weeks  during  1981,  three  weeks  in  the  summer,  and  one  week 
in  both  the  fall  and  winter.  Durinq  the  winter  and  fall  according  to  the 
CIRA  model  there  should  be  a  stratospheric  sound  channel  from  the  south¬ 
east  Indian  Ocean  to  Windless  Bight  and  according  to  our  estimate  of  the 
stratospheric  winds  there  should  be  a  stratospheric  sound  channel  during 
the  sprina,  summer  and  fall.  Again  as  with  the  microbaroms  received  from 
the  Weddell  Sea  this  leads  to  the  conclusion  that  there  was  not  a  regular 
source  of  microbaroms  from  the  Southeast  Indian  Ocean  and  they  were  genera¬ 
ted  by  large  storms  that  are  not  a  regular  feature  to  that  area. 

The  number  of  si  anal  s  observed  per  month  for  the  Ross  Sea  area  and 
the  Bellingshausen  Sea  area  is  shown  in  Figure  10.  We  should  point  out 
that  the  microphone  array  was  offline  during  the  last  two  weeks  of  June 
and  during  all  of  July.  This  is  the  reason  for  the  absence  of  signals 
detected  during  those  two  months.  The  number  of  signals  from  the  Ross 
Sea  area  was  greatest  in  the  summer  and  falls  off  rapidly  during  March 
(fall).  Microbaroms  are  generated  by  standing  waves  on  the  surface  of 

10 
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the  ocean.  The  sudden  drop  In  the  number  of  signals  detected  from  the 
Ross  Sea  in  March  sugoested  that  the  freezing  over  the  Ross  Sea  may 
he  the  cause  of  this  decrease.  As  we  saw  in  Figure  3  the  Ross  Sea  is 
covered  by  sea  ice  during  the  winter  and  free  of  ice  the  summer.  Weekly 
sea  ice  maps  for  1981  show  that  the  Ross  Sea  had  total  sea  ice  cover 
first  in  the  middle  of  March. 

The  high  number  of  signals  from  the  Ross  Sea  area  in  the  summer  can 
be  attributed  to  the  relatively  short  propaaatino  path  lenoth  from  the 
Ross  Sea  to  Windless  8ight  (horizontal  distance  «  300  km).  Ray  tracing 
routines  have  been  used  to  show  that  it  takes  only  one  reflection  in  the 
stratosphere  for  a  sound  wave  from  the  Ross  Sea  to  reach  Windless  Biaht. 
Using  a  similar  argument  the  absence  of  signals  from  the  Bellingshausen 
sea  area  during  the  summer  can  be  attributed  to  the  long  acoustic  path 
length  from  the  Bellingshausen  Sea  to  Windless  Bight  (horizontal  distance 
-  300  km).  The  increased  number  of  signals  from  the  Bellingshausen  Sea 
during  winter  was  probably  due  to  large  storm  systems  that  develop  in 
that  area  in  winter. 

The  hourly  variations  of  the  rms  levels  for  microbaroms  from  the  Ross 
Sea  and  Bellingshausen  Sea  areas  averaged  over  1981  is  shown  in  Figure  11. 
Note  that  the  pattern  for  the  microbaroms  from  the  Bellingshausen  Sea  have 
a  12-hour  variation  while  there  is  a  24-hour  variation  for  the  signals 
from  the  Ross  Sea.  The  12-hour  variation  in  the  rms  level  of  microbaroms 
from  the  Bellingshausen  Sea  suggests  that  microbaroms  from  that  area  were 
reflecting  in  the  lower  thermosphere.  This  is  in  agreement  with  the  wind 
and  temperature  profiles  discussed  earlier. 
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The  24-hour  variation  In  the  rms  level  for  mlcrobaroms  from  the 
Ross  Sea  area  can  be  explained  by  the  presence  of  a  diurnal  wind  in 
the  stratosphere  over  Windless  Bight.  From  Equation  2  we  can  see  that 
a  diurnal  wind  in  the  stratosphere  will  cause  a  diurnal  variation  in 
the  maximum  trace  velocity  reflected  in  the  stratosphere.  This  will 
then  cause  a  diurnal  variation  in  the  amount  of  wave  energy  reflected 
in  the  stratosphere.  Figure  12  shows  the  average  trace  velocity  per 
hour  averaaed  over  1981  of  microbaroms  from  the  Ross  Sea.  This  shows 
a  12  meter  per  second  variation  over  24  hours.  The  amplitude  and  phase 
of  this  variation  aarees  well  with  the  theory  given  on  the  diurnal  tide 
earlier.  There  was  no  Indication  in  the  microbarom  data  of  the  presence 
in  the  microbarom  data  of  a  semidiurnal  tidal  wind  in  the  stratosphere. 
This  is  probably  due  to  the  low  amplitude  of  the  semidiurnal  tidal  wind 
in  the  stratosphere. 

The  average  trace  velocity  as  a  function  of  azimuth  for  1981  is  shown 
in  Figure  13.  This  variation  in  the  trace  velocity  for  microbaroms  from 
different  directions  is  a  result  of  the  variation  of  the  stratospheric 
winds  and  the  level  of  wave  reflection  that  occurs  along  different  propa¬ 
gation  paths.  The  maximum  trace  velocity  of  379  meters  per  second  for 
microbaroms  from  an  azimuth  of  340°  occurred  when  the  acoustic  raypaths 
were  parallel  to  the  stratospheric  winds.  The  minimum  trace  velocity  of 
327  meters  per  second  from  125°  occurred  for  microbaroms  that  were  re¬ 
flected  in  the  thermosphere  because  the  stratospheric  sound  channel  was 
closed.  Microbaroms  with  high  trace  velocities  that  were  reflected  in 
the  thermosphere  would  suffer  more  dissipation  than  microbaroms  with 
lower  trace  velocities  (Donn  and  Rind,  1972).  Assuming  a  scaler  sound 
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speed  due  to  temperature  alone  of  340  meters  per  second  in  the  strato- 
f  sphere  over  Windless  Bight  then  the  average  stratospheric  wind  would 

equal  the  maximum  average  trace  velocity  minus  the  scaler  sound  speed. 
This  allows  an  estimate  to  he  made  for  1981  of  the  average  stratospheric 

♦  wind  over  Windless  Bight  of  at  least  39  meters  per  second  from  an  azimuth 
of  340°.  We  also  looked  at  the  variation  of  the  averaoe  trace  velocity 
as  a  function  of  azimuth  of  arrival  for  each  season.  For  the  winter 
season  there  was  not  enough  variation  in  the  azimuth  of  arrival  of  the 
microbaroms  to  compare  to  the  other  seasons.  There  was  little  variation 
in  the  average  trace  velocity  as  a  function  of  azimuth  of  arrival  between 

♦  the  three  seasons,  spring,  summer  and  fall. 

fi.  COMCIUSIOMS 

The  use  of  a  digital -data  acquisition  system  has  allowed  us  to  detect 

♦ 

many  more  infrasonic  signals  than  with  an  analog  system.  We  receive 
microbaroms  from  four  different  areas,  the  Ross  Sea,  the  Bellingshausen, 
the  Weddell  Sea  and  the  southeast  Indian  Ocean.  Of  the  four  source  areas, 

t 

the  Ross  Sea  and  the  Bellingshausen  Sea  are  the  most  dominant  source  of 
microbaroms,  as  observed  at  Windless  Bight.  The  microbaroms  received 

from  the  Weddell  Sea  and  the  southeast  Indian  Ocean  seem  to  be  generated 

t 

by  large  storms  that  are  not  reaular  features  of  those  areas  system. 
Variations  in  the  number  of  microbarom  signals  from  the  Ross  Sea  area 
were  shown  to  be  caused  by  the  freezing  over  of  the  Ross  Sea.  Semi- 

» 

diurnal  variations  in  the  rms  levels  of  signals  from  the  Bellingshausen 
Sea  indicate  that  the  waves  from  that  area  were  reflecting  in  the  lower 

» 
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thermosphere.  The  diurnal  variations  of  the  average  trace  velocity  and 
the  rms  level  of  the  microbaroms  from  the  Ross  Sea  area  Indicate  the 
presence  of  a  diurnal  wind  over  Windless  Bight  with  a  magnitude  of  over 
5  meters  per  second.  The  variation  of  the  average  trace  velocity  as  a 
function  of  azimuth  for  1981  indicates  that  the  average  stratospheric 
wind  over  Windless  Bight  was  from  340°  and  had  a  magnitude  of  greater 
than  39  meters  per  second.  The  diurnal  wind  suggested  by  the  diurnal 
variations  of  the  rms  level  and  average  trace  velocity  of  microbaroms 
from  the  Ross  Sea  agrees  well  with  Chapman  and  Lindzen  (1970).  The 
average  stratospheric  winds  estimated  were  quite  different  from  the  CIRA 
1966  model.  The  CIRA  1966  model  has  seasonal  changes  in  the  direction 
of  the  zonal  winds,  while  we  observed  no  change  in  direction  for  three 
of  the  four  seasons.  Also,  the  CIRA  model  gives  no  information  on  the 
meridional  component  of  the  stratospheric  winds  and  we  detected  there 
to  be  a  large  meridional  component  to  the  stratospheric  wind  over  Windless 
Bight. 
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FIGURE  CAPTIONS 


f  Figure  1.  A  nap  of  Antarctica  showino  Windless  Biqht  and  the  four  source 

reqions  for  nlcrobaroms  for  Windless  Bight,  the  Ross  Sea,  the 
Bellinoshausen  Sea,  the  Weddell  Sea,  and  the  southeast  Indian  Ocean. 

Figure  2a.  Temperature  (in  degrees  kelvin)  as  a  function  of  height  and 
latitude  as  oiven  by  the  CIRA  1966  node!  for  the  months  of  January 

’  and  July. 

Figure  2b.  Sane  as  Figure  2a  except  for  April  and  October. 

Figure  3.  Average  ice  pack  for  ‘larch  (minimum)  and  September  (maximum). 

Figure  4a.  Mean  surface  isotherms  (in  degrees  Celsius)  for  the  month 

of  January. 

Figure  4b.  Same  as  Figure  4a  except  for  July. 

Figure  5a.  Mean  zonal  winds  as  a  function  of  height  and  latitude  as 

*  qiven  by  the  CIRA  1966  model  for  the  months  of  January  and  July. 
Positive  winds  are  westerly  winds. 

Figure  5b.  Same  as  Figure  5a  except  for  April  and  October. 

Fioure  6.  Meteorological  rocket  sounding  data  for  McMurdo  Station 

from  27  September  1962.  Derived  winds  as  a  function  of  height 
are  qiven  on  the  left.  Zonal  winds  are  given  by  the  dashed  line 
and  meridional  winds  by  the  solid  line. 

Fioure  7a.  The  amplitude  of  the  solar  diurnal  wind  as  a  ^unction  of 
height,  given  at  15  intervals  in  latitude.  After  Chapman  and 

*  Lindzen  (1970). 

Figure  7b.  The  phase  of  the  solar  diurnal  wind  (hour  of  maximum)  as  a 
function  of  height,  given  at  15  intervals  in  latitude. 

.  Figure  8a.  The  amplitude  of  the  solar  semidurnal  wind  as  a  function  of 

height,  qiven  at  various  latitudes.  After  Chapman  and  Lindzen  (1970). 

Figure  8b.  The  phase  (hour  of  maximum)  of  the  solar  semidiurnal  wind  as 
a  function  of  height,  given  for  various  latitudes. 

I  Figure  9a.  The  number  of  signals  as  a  function  of  azimuth  of  arrival  for 

the  months  of  January,  February  and  December. 

Figure  9b.  Same  as  Figure  9a  except  for  March,  April  and  May. 


16 


Figure  9c.  Same  as  Figure  9a  except  for  September,  October,  and 
November. 

Figure  10.  The  number  of  signals  per  month  for  the  Ross  Sea  (solid 
line)  and  the  Bellingshausen  Sea  (dashed  line). 

Figure  11.  The  RMS  level  per  hour  (UT)  for  the  Ross  Sea  (solid  line) 
and  the  Bellingshausen  Sea  (dashed  line). 

Figure  12.  The  average  trace  velocity  of  microbaroms  from  the  Ross 
Sea  per  hour  (UT). 

Figure  13.  Horizontal  trace  velocity  as  a  function  of  azimuth  for 
1 9B1 . 
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SECTION  2:  SIGNAL  DETECTION  IN  SCALAR  ARRAYS: 


APPLICATION  OF  AOAPTIVE,  PURE-STATE  FILTERS  TO  INFRASONIC  ARRAY  DATA* 


*A  paper  presented  at  the  Symposium  on  Signal  Processing, 
European  Geophysical  Union,  Leeds,  End! and,  1982. 
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Introduction 


The  Geophysical  Institute  of  the  University  of  Alaska  operates  an  array 
of  seven  lnfrasonic  microphones  at  Windless  Bight,  Antarctica.  The  micro¬ 
phones  are  arranged  in  two  nested  arrays  as  shown  in  Figure  1  to  provide  both 
long  period  and  short  period  signal  detection.  After  band-pass  filtering  at 
frequencies  appropriate  to  each  array  the  signals  are  digitized  and  logged  on 
magnetic  tape  by  a  DEC  LSI-11  microcomputer.  Details  of  the  microphones, 
filter  and  digital  recording  systems  are  described  in  a  report  by  Spell  et  al . 
which  is  available  upon  request  from  the  Geophysical  Institute,  University  of 
Alaska. 

The  search  for  signals  in  the  lnfrasonic  data  is  carried  out  both  in 
real-time  and  off-line  analyses  by  a  microcomputer.  Real-time  analysis  is 
performed  by  the  microprocessor  while  it  waits  to  log  incoming  data  values. 
In  this  mode  it  performs  cross  correlations  and  searches  the  raw  and  pure- 
flltered  data  for  signal  arrival  azimuth  and  velocity.  Off-line  analyses  are 
carried  out  on  other  computers  to  re-examine  the  detected  signals  and  quantify 
their  parameters  using  a  variety  of  signal  analysis  routines. 

II.  Adaptive,  Pure-State  Filters 

The  construction  of  data-adaptlve ,  pure-state  filters  and  their 
application  to  a  variety  of  data  types  from  geophysics  along  with  references 
to  the  development  of  the  technique  has  been  given  by  Samson  and  Olson  (1981); 
one  application  to  long  period  lnfrasonic  data  has  been  given  by  Olson 
(1982).  Briefly,  the  technique  can  be  outlined  symbolically  as  follows: 
consider  the  time  sequence  from  the  iC^  microphone,  Xj,(t).  It  may  be  grouped 
together  with  the  sequences  from  N  microphones  to  form  the  vector 
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x(t)  -  (xjCt),  x2(t),  ...  xn(c))T 


(1) 


where  T  represents  the  transpose  of  the  vector.  Computing  the  Fourier 
transform  of  x(t)  we  obtain  the  frequency  domain  vector 


X(oj)  -  (X^w),  X2(u), 


(2) 


From  this  we  may  obtain  an  estimate  of  the  spectral  matrix 

S(w)  -  <X(oj)  X(oj)+> 


(3) 


where  <  >  represents  an  average  in  the  frequency  domain  and  +  represents  the 
complex  conjugate  transpose  operation.  The  spectral  matrix  at  frequency  w  is 
an  Hermitian  matrix  whose  real  eigenvalues,  o^,  represent  the  signal  power. 
Its  eigenvectors,  represent  various  signal  states  contained  In  the  sampled 
data  sequence.  If  only  one  eigenvalue  is  nonzero  and  the  rest  are  zero 
then  the  signal  Is  described  exactly  by  the  pure-state  eigenvector  £^(u>). 
Samson  (1973)  has  shown  that  an  estimator  of  the  degree  to  which  a  spectral 
matrix  approaches  a  pure-state  is  given  by 


p(u)  _  N(TrS2(ui)  -  (Tr  S(u))2 
(N  -  1)  (Tr  S(u>) )2 


(4) 


where  Tr  Is  the  trace  operation,  N  is  the  number  of  data  channels.  P(w)  is  a 
scalar,  0  <  ?(u>)  <  1  and  P(u)  ■  0  Indicates  an  uncorrelated  noise  sequence  and 
P(u>)  •  1  indicates  a  pure-state  signal  sequence.  P(cj)  is  an  estimator  of  the 
multivariate  coherence  of  the  data  and  is  derived  from  rotational  invariants 
of  the  spectral  matrix. 
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Now,  observe  that  P(oo  )  is  a  scalar  sequence  in  the  frequency  domain 
which  represents  the  degree  to  which  the  signal  variance  at  each  frequency  can 
be  described  by  a  unique  eigenvector  state.  As  such,  P(w)  may  be  used  as  a 
filter  to  modulate  the  spectrum.  That  is,  we  may  achieve  a  filtered  sequence 
as 


x^(t)  *  /  X^u)  P(uj)e+^Wtdf  (5) 

— CQ 

Since  P(o>)  is  derived  from  the  data  themselves  it  is  truly  an  adaptive 
filter. 

Tests  of  the  filter  performance  using  infrasonlc  data  have  shown  that 
signals  can  be  detected  15  to  20  db  below  the  noise  (Olson,  1982).  In 
practice,  when  implemented  in  the  real-time  data  analysis  procedure  in 
Antarctica  the  number  of  events  detected  using  pure-filtered  data  increased  by 
more  than  an  order  of  magnitude  compared  with  the  number  detected  in  the 
unfiltered  data.  An  example  of  the  improvement  in  signal  statistics  achieved 
with  pure-filtered  data  is  shown  in  Figure  15.  We  have  plotted  a  histogram 
showing  the  number  of  mountain-associated  infrasonic  waves  arriving  from 
various  azimuths.  Here  we  have  evidence  of  two  strong  sources  at  140®  and 
340®  azimuth.  Note  that  there  are  over  500  events  recorded.  No  mountain- 
associated  waves  were  observed  in  the  untreated  data.  The  signal  levels  were 
generally  low  enough  to  escape  traditional  least-squares  event  detection  based 
upon  bivariate  correlations. 

III.  Pure-Fllterlng  and  Beam  Steering 


Data  sequences  from  scalar  arrays  which  contain  the  arrivals  of  plane 
wavefronts  may  be  analyzed  and  filtered  using  the  phase  information  implicit 
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in  the  lagged  arrival  of  the  plane  wavefront  at  each  sensor.  A  great  deal  of 
work  has  been  carried  out  in  this  area  and  is  summarized  in  the  book  Adaptive 
Arrays  by  Monzingo  and  Miller  (1980).  In  essence,  the  time  delay  between 
arrivals  of  a  wavefront  at  two  microphones  separated  by  the  vector,  is 

given  by  x  -  _s  •  where  £  is  the  slowness  (inverse  of  velocity)  of  the 
wave  with  direction  parallel  with  the  wave  motion.  The  set  of  delays  x^ 
transforms  to  a  set  of  phase  differences  <t>^  .  Classical  beam— stearing 
detectors  can  be  written  in  this  notation  as 


D(w)  -  b+  S.(u))b 


(6) 


where  D(w)  is  a  scalar  amplitude  which  results  when  the  spectral  matrix  ^>(w) 
is  projected  upon  the  subspace  j5  ■  Js  b+,  and  £  is  the  vector  of  phases 


b  -  (1, 


-il) 
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-i<t> 
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“I'D 


1N> 


(7) 


The  efficacy  of  the  beam-stearing  algorithms  may  be  increased  dramatically  by 
pure-filtering  the  data  prior  to  the  application  beam-steering  algorithm.  We 
have  found  that  the  problems  in  signal  detection  and  parameterization  are 
eased  through  the  Increased  contrast  in  signal  to  noise  provided  by  the  pure- 
state  filter.  Figures  16  and  17  show  a  signal  detected  in  slowness-frequency 
(S-9)  space  using  beam-steering  techniques;  the  enhanced  contrast  provided  by 
the  pure-filtered  data  is  easily  seen. 


IV.  Approaches  to  Anisotropic  Noise 


We  assume  in  all  of  our  analyses  that  the  noise  is  stationary  in  time. 
This  has  proven  to  be  a  reasonable  assumption  in  the  analysis  of  infrasonic 
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data,  at  least  over  Intervals  of  a  few  tens  of  minutes.  However,  it  is  often 
the  case  that  the  noise  is  not  isotropic  in  amplitude  across  the  array  of 
microphones.  In  this  case,  the  pure-filter  is  ineffective  since  the  noise 
field  itself  becomes  an  identifiable  signal  state  which  is  different  from 
isotropic  noise. 

We  have  approached  the  problem  of  anisotropic  noise  using  two  techniques 
which  we  have  found  equally  successful.  The  first,  and  simplest,  is  to  adjust 
the  data  sequences  to  unit  variance  prior  to  pure-filtering.  In  essence,  we 
have  spatially  “prewhitened"  the  data. 

In  our  second  approach  we  have  incorporated  a  suggestion  by  Cox  (1973). 
If  we  can  identify  a  data  sequence  which  is  free  of  signal  and  thus  represents 
only  noise,  the  characteristics  of  the  noise  may  be  represented  by  its 
spectral  matrix  Q(a)).  This  can  be  used  as  a  metric  defining  the  "noise 
space".  If  the  noise  Is  stationary  in  time,  the  signal  will  be  imbedded  In 
the  noise  field  CKu>) .  In  order  to  minimize  the  effects  of  anisotropic  noise 
the  information  In  the  spectral  matrix  may  be  projected  on  a  subspace  where 
the  noise  appears  isotropic.  This  is  performed  by  carrying  out  the 

transformation 

£(<*>)  -  Q_1/2  S  Q*1/2  (8) 

However,  if  the  signal  being  sought  is  itself  substantially  orthogonal  to  the 
subspace  being  used,  the  method  may  not  yield  any  Increase  in  signal  to 
noise.  There  is  no  a  priori  method  by  which  to  judge  the  efficacy  of  this 
approach.  One  must  simply  try  and  judge  the  results  accordingly. 
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While  we  use  a  wide  variety  of  signal  analysis  techniques  in  our  search 
of  events  in  the  infrasonic  data  from  Antarctica  we  have  found  the  performance 
of  each  is  improved  when  the  data  are  pure-filtered  prior  to  analysis. 
Further,  because  of  the  generality  of  the  pure-filter  in  rejecting  isotropic 
noise  fields  independent  of  their  spectral  content,  it  is  the  only  process 
which  we  allow  to  operate  on  the  data  in  real-time  analyses.  We  have  found 
the  number  of  signals  detected  has  increased  by  more  than  an  order  of 
magnitude  using  pure-filtered  data  and  in  the  off-line  analysis  the  efficacy 
of  every  subsequent  analysis  technique  is  enhanced . 


References 


Cox,  H.,  Resolving  power  and  sensitivity  to  mismatch  of  optimum  array 
processors,  J.  Acous.  Soc.  Am.,  54,  771,  1973. 

Monzingo,  R.A.  and  T.W.  Miller,  Introduction  to  Adaptive  Arrays,  Wiley- 
Interscience,  1980. 

Olson,  J.V.,  Noise  suppression  using  data-adaptive  polarization  filters: 
applications  to  infrasohic  array  data,  J.  Acous.  Soc.  Am.,  November  1982. 

Samson,  J.C.,  Descriptions  of  the  polarization  states  of  vector  processes: 
Applications  to  ULF  magnetic  fields,  Geophys.  J.  Roy.  Astr.  Soc.,  34,  403, 
1973. 

Samson,  J.C.  and  J.V.  Olson,  Data-adaptive  polarization  filters  for 
multichannel  geophysical  data.  Geophysics ,  46,  1423,  1981. 

Spell,  B.D.,  J.V.  Olson,  and  C.R.  Wilson,  Antarctic  digital  infrasonic  system 
upgrade,  Report  GIR  82-1,  Geophysical  Institute,  University  of  Alaska, 
1982. 


FIGURE  CAPTIONS 


Figure  1 


Flaure  2 


Fiqure  3 


Figure  4 


The  University  of  Alaska  Infrasonic  microphone  array  at 
Windless  Bight,  Antarctica.  The  cluster  of  microphones 
comprise  two  nested  arrays  with  spacing  appropriate  for 
short  period  and  long  period  signal  detection. 

The  number  of  mountain  associated  infrasonic  waves 
detected  at  Windless  Bight,  Antarctica  during  1981  as  a 
function  of  azimuth.  These  signals  were  not  detectable 
in  the  records  prior  to  pure-filtering. 

A  slowness-azimuth  diagram  showing  a  signal  detected  by 
the  F-array  and  its  echos  in  the  array  sidelobes.  The 
signal  is  present  in  the  main  lobe  of  the  array  at  a 
slowness  of  3  sec/km  and  an  azimuth  of  aproximately  210°. 
This  diagram  was  generated  from  the  raw  microphone  data. 

A  slowness-azimuth  diagram  of  the  signal  described  in 
Figure  16  after  pure-filtering  the  data.  Mote  the  in¬ 
creased  signal-to-noise  contrast  when  compared  with  the 
pattern  in  Figure  3. 
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SECTION  III.  SOFTWARE  DEVELOPED  FOR  INFRASON1C  SIGNAL 
PROCESSING  ON  THE  PDP  11/03 
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DATA  RETRIEVAL  PROORAMS 


These  programs  wars  written  by  Dave  Spell  and  Eruce  McKibben  to  scan  or 

recalculate  the  data  tapes  created  bt/RTGAIU  (revisions  10  or  later). 

These  programs  use  the.  routines  in  REDLI5  and  the  MACRO  routines  in 

MACLIS.  These  programs  may  be  found  on  disks  labeled  SCAN  FILES. 

i  AZSCAN  A  program  which  scans  the  tape  for  blocks  within  the  user 

specified  azimuth  range.  The  user  specifies  a  minimum  RHC  and 
DELTA  RHO. 

READ  A  program  which  reads  and  recalculates  the  data  from  a  tape. 

An  option  is  made  available  to  the  user  for  tweaking  the 
polarization  filter.  In  F  array  analysis*  READ  will  give  valid 
results  for  the  first  block  calculated*  provided  that  the  start 
t  '  block  is  at  least  four  more  than  the  current  position  of  the 

tape. 

RPTSCN  A  program  similiar  to  SCAN,  but  with  an  output  in  the  form  of 
an  Inrrasonics  Report  message.  The  output  goes  to  FTN19.DAT. 

SCAN  A  program  which  scans  the  tape  for  all  blocks  with  RHO  or  DELTA 
P  RHO  greater  than  the  user  specified  minimums. 

SCNTWK  A  program  similiar  to  READ*  however*  only  the  post— filtered 

time  domain  analysis  is  performed*  and  output  is  printed  only 
for  those  blocks  with  RHO  greater  than  user  specified  minimums. 

STATS  A  program  to  scan  one  or  more  tapes  and  give  the  average  values 
of  the  statistics  for  each  channel. 


» 


non 


C************  AZSCAN  .FOR  %*%&**%***ZXX*t**XX***%M****X*X****%****X**.% 
Date  of  revision l  4-Nov-82 
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PROGRAM  AZSCAN 
PURPOSE 

To  scan  3  tare  for  blocks  of  interest  within  a  user  specified 
szimuth  range. 

USAGE 

RUN  AZSCAN 

INPUT  PARAMETERS 

YEAR  -  A  two  digit  integer 

F*T*B  -  Selects  F  array*  T  array*  or  Both  arrays 
RHOMIN  -  Minimum  average  correlation  coefficient  for  Mocks  of 
interest  (default  0.7  if  T*  0.5  if  F) 

DIFHIN  -  Minimum  change  in  average  correlation  coefficient  after 
polarization  filtering  (default  0.2) 

STATS  -  If  Y  is  entered*  statistics  will  be  printed  for  each 
block  of  interest 

ALL  -  If  Y  is  entered*  data  for  all  blocks  in  range  will 
be  printed.  Otherwise*  only  the  first  end  last. 

AZMIN  -  Minimum  value  of  azimuth  range  (0.  <  AZMIN  <  3*0.) 

AZMAX  -  Maximum  value  of  azimuth  range  (0.  <  AZMAX  <  360.  ) 

UELMIN  -  Minimum  value  of  velocity  range  (default  250.  ) 

UELMAX  -  Maximum  value  of  velocity  range  (default  700.  ) 

START  -  Integer  value  of  first  block  to  be  scanned 

STOP  -  Integer  value  of  last  block  to  be  scanned 

REMARKS 

Uhen  the  azimuth  range  includes  360.  degrees*  it  is  acceptable 
to  enter  a  value  of  AZMIN  that  is  larger  than  AZMAX*  i.e. 
AZMIN=345.  and  A2MAX=25.  covers  the  range  including  360.  degrees 

LIBRARIES  REQUIRED 

redlib*maclib*sy:forlib 

METHOD 

The  program  scans  the  trailer  data  of  the  tape  starting  at  START 
If  the  value  of  RH0  is  greater  than  RHOMIN  or  the  change  in  RH0 
is  greater  than  DIFMIN*  then  the  program  checks  to  see  if  the 
signal  is  within  the  specified  azimuth  range.  If  so*  the  anelysi 
data  (and  statistics  if  reouested )  are  printed.  Uhen  the  last 
block  (STOP)  is  read*  the  average  values  of  the  analysis  data 
are  printed.  The  program  then  allows  for  another  scan. 

COMMON  /MTBLK/  IDNSTY * IPARTY » ISTATU( 12) 

DIMENSION  IWNSPOt  2.168  ),IMP0NG(  100) 

COMMON  /TRAILY/  IMPING<  2063  ) » FVEL0C  *  FAZIMF ,  FVEUAR.  FAZt'AR .  IFST AT  , 

C F MU<  4  )»FPSI<  4  >»FRH0(  6  ),IFMAX(  4  >*IFMIN<4  )  *  IFSPQX  » FRH0VX  . FUEL0X  * 

CFAZIMX »FUEVAX .FAZVAX » TVEL0C* T AZIMF * TVEUAR » TAZVAR * ITSTAT , TMIK  3  )» 

CTPSK  3  >*TRHO<  3  >*  ITMAX(  3  ) ,  ITMIN(  3  ) .  ITSPGX  ,  TRH0VX . TUEL0X * TAZ  TMX  , 

( TVEVAX.TAZVAX 

DIMENSION  IHEADR( 20  )»IHEAD2( 20  )*IHEAD1( 20  ) 

DIMENSION  F3IGMA( 4  )*TSIGMA(  3  ) 

DATA  IZER0/0/. FOUR/ 1HF/ *THREE/1HT/* BOTH/ 1HB/ 

DATA  XN0/1HN/*YES/1HY/*IN0/-1/*IYES/1/ 


o  o  n  o 


OAT  A  I UN IT/OO/ , IDNSTY/3C0/ , IPARTY/l/f IREV/-1/ 

C.  .  .  ..  .  . . *  .  . . . . 

C 

C  Program  and  »ag  tape  in i  ti si  i zatiori  sres. 

C 

100  TYPE  10 

TYPE  193 
ACCEPT  19 » .JYEAR 
C 

102  CALL  HTIMIT(  IUNIT  ) 

IF  ( ISTATU( 1 >  .NE.  IYES  )  STOP 
C 

110  IGFLAG  =  INO 
TYPE  13 

ACCEPT  12  * ARRNBR 
C 

TYPE  13 

ACCEPT  14 ,  RHON I N 
TYPE  171 

ACCEPT  14 » HIFMIN 
IF  (  KHOrtIN  ,NE,  0.)  GO  TO  111 
IF  (  ARRNBR  .EQ .  THREE)  RHQMIN=0.7 
IF  (ARRNBR  »EQ .  FOUR)  RH0MIN=0.5 

IF  ((ARRNBR  .NE.  THREE)  ♦AND .  (ARRNBR  .NE.  FOUR))  GO  TO  110 

111  IF  ( DIFMIN  .EQ.  0.)  BIFNIN=0.2 
C 

TYPE  16 

ACCEPT  12, STATS 
TYPE  15 
ACCEPT  12 » ALL 


Average  values  initialization  area 
TYPE  177 

ACCEPT  178 ,  AZMIN, AZMAX 
TYPE  179 

ACCEPT  178,  VELMIN » t'ELMAX 
IF  (VELMIN  .EQ.  0.)  VELMIN=250. 

IF  (UELMAX  .EQ.  0.)  VEL«AX=700. 
AZNINP=AZMIH 

IF  (  AZiilN . GT  .  AZHAX  )  AZMIN=AZMIN-360 . 

ITNUN=0 

IFNUM=0 

ITSET=0 

IFSET =0 

TRT =0 . 

FRT=0. 

TAZT=0. 

FAZT=0 . 

TCZT  =  0 . 

FCZT =0 . 

TVT  =  0 . 

FVT  =0 . 

TCVT=0. 

FCt'T  =  0 . 

TORT =0 . 

FORT =0 . 

TNDRT=0 . 

FHDRT =0 . 


non 


Tape  reed  end  sverade  values  calculation  area 


200 


t 

C 

243 

C 

209 

245 

C 


t 


C 

205 


» 


C 

220 

C 

208 


I 


I 


221 


» 


I 


TYPE  190 

ACCEPT  19»ISTART»IST0P 
IF  (ISTART  . EQ .  0)  ISTART  =  1 
IF  (ISTOP  .EQ.  0)  ISTOP  =  10000 
ISTOPR  =  ISTOP  +  2 

DO  243 » I  =  2049 .2168 
IMPING*  I  )  =  0 

DO  245. I  =  lr 100 
II  =  I  +  2068 
1MPONG*  I  )  =  IMPING*  31  ) 

IF  ( IGFLAG  .EQ.  IYES)  GO  TO  201 

CALL  REDT AP<  IUNIT  » IMPING. I NRBYT  » I  STATU  ) 

IF  (1ST ATU<  1  )  .EQ.  IYES)  GO  TO  205 
CALL  MTSTAT* IUNIT ) 

IF  (  I  STATU*  3 )  .EQ.  IYES)  GO  TO  208 
GO  TO  209 

IF  (IMPING*  2)  .EQ.  ISTART)  GO  TO  22  0 
IFUB  =  ISTART  -  IMPING* 2  ) 

IFUD  =  IFUD  -  1 

IF  (IFUD  .EQ.  0)  GO  TO  209 

CALL  SPCTAP  *  IUNIT .IFUD, 1ST ATU  ) 

IF  ( ISTATU* 1  )  .EQ.  INO )  STOP 
GO  TO  209 

IF  < IMPING*  2  )  .LE.  ISTOPR)  GO  TO  204 

IF  ( ARRNBft . EQ .FOUR )  GO  TO  221 
IHEADR*  2  )=0 
IHEAD2*  2  >=0 
I HEAD 1*  2  )=0 

IF  ( ITNUM  .EQ.  0)  GO  TO  221 
TNUM=FLOAT* ITNUM) 

T3ET=FL0AT( ITSET  )/TNUM 

TCZT=TCZT/TNUM 

TCVT=TCUT/TNUM 

TDRT=TDRT/TNUM 

TAZT=TAZT/TNUM 

T<JT  =  TVT/TNUM 

TYPE  175  »  ITNUM >  TSET  *  TRT  »  TBRT  »  TMDRT  » TAZT  » TCZT  .  TVT  » TCV'T 
IF  * ARRNBR.EQ. THREE )  GO  TO  222 
IF  < IFNUM  .EQ.  0)  GO  TO  222 
FNliM=FLOAT<  IFNUM  ) 

FSET=FLOAT< IFSET >/FNUN 

FCZT=FCZT/FNUM 

FCVT=FCVT/FNUM 

FDRT=FDRT/FNUM 

FAZT=FAZT/FNUM 

FVT  =FUT /FNUM 

TYPE  1/5.IFNUM.FSET.FRT.FDRT  .  FMDRT  ,  F  AZT  .  FCZT  .  Ft'T  » FCt'T 


C 

222  PAUSE  '  **#DONE***' 
GO  TO  110 


» 


o  o  o  o 


CALL  REDTAP< IUNI T » IUKSPC > INRBYT , ISTATU ) 
IF  < ISTATU<  1  )  .EQ.  IYES)  GO  TO  211 
CALL  HTS7AT(  IUN1T  ) 

IF  (ISTATU(S)  .EQ.  IYES)  GO  TO  203 
GO  TO  204 

IF  ( IWKSPC(  2  >  .NE.  I HP I NG(  2  ) )  GO  TO  214 
IF  (IUKSPC<4>  .NE.  INPING<  4  )  )  GO  TO  214 
IF  (ALL  .EQ.  YES)  TYPE  17,INPING(2) 

DO  217.1  =  1.2168 
INPING(  I  )  =  IUKSPC(  I  ) 

IGFLAG  =  INO 
GO  TO  204 


IGFLAG  =  IYES 

IF  (INPING<2)  .GT.  ISTOPR  >  GO  TO  203 


Tape  blocK  setup  snd  TErrO  detection  sree 

300  DO  301.1  =  1.20 

IHEADRC I  )  =  IHEAD2(  I  ) 

IHEAD2(  I  )  =  IHEADK  I  ) 
t  301  IHEADK  I  )  =  I  HP  I  NG(  I  ) 

C 

ITRFLG  =  0 
IFRFLG  =  0 

DO  343.1  =  215S.2163 
I I  =  I  -  2068 

»  34-3  IF  (  IHPING(  I  )  .EQ.  IMPONG(II))  ITRFLG  =  ITRFLG  +  1 

IF  (ITRFLG  .EQ.  11)  GO  TO  347 
DO  345,1  =  2114,2124 
II  =  I  -  2068 

345  IF  (INFING(I)  .EQ.  INPONG(  II ) >  IFRFLG  =  IFRFLG  +  1 

IF  ((IFRFLG  .EQ.  11)  .AND.  (ALL  .EQ.  YES))  TYPE  173.  IKEADR(  2  ) 
»  GO  TO  34? 

347  DO  343,1  =  2069,2124 
II  =  I  -  2068 

348  IF  (IKFING(I)  .EQ.  IMPONG(  II  ) )  ITRFLG  =  ITRFLG  +  1 
IF  (ITRFLG  .LT.  67)  GO  TO  349 

IF  (ALL  .EQ.  YES)  TYPE  172 ,  IHEADR(  2  ) 

»  GO  TO  209 

C 

34?  FRHOVG  =  0. 

DO  302,1  =  1,6 

302  FRHOOG  =  FRHOVG  +  FRHO< I  ) 

FRHQVG  =  FRHOVG/6. 

»  C 

DO  304.1  =  1,4 

FSIGMA(  I  )  =  FPSI(I)**2  -  FNIK  I  )**2 
IF  (FSIGNA(I)  .LT.  0.)  FSIGHA(  I  )  =  0. 

304  FSIGHA(  I )  =  SQR T  (  F S I  GMA(  I  )) 

C 

»  TRHOVG  =  0. 

DO  303,1  =  1,3 

TSIGNA<  I  )  =  TPSK  I  )**2  -  TMIK  I  )**2 
IF  (TSIGHA(I)  .LT.  0.)  TSIGNA(I)  =  0. 

TSIGHA-  I  >  =  SQRT(  TSIGNA(  I  )  ) 


» 


o  n  o  o 


L 


303  TRHOVG  =  TRHOVG  +  TRHO< I  ) 
t  TRHOVG  =  TRHOOG/3. 

TRODIF  =  TRKOVX  -  TRHOVG 
FROBIF  =  FRHQVX  -  FRHOVG 
C 

IF  < IHEADR<  2  )  .GE.  ISTART)  GO  TO  600 
GO  TO  209 


T  arrstf  sisinel  detection  zrez 


600 


t 


t 


c 

623 


» 


C 


♦ 


c 


641 

609 

601 

606 

663 

661 


» 


651 


C 


IF 

(TRHOVG  .GE. 

RHOM  IN) 

GO 

TO 

623 

IF 

(TRHQVX  .GE. 

RHOMIN) 

GO 

TO 

623 

IF 

<  FRHOUG  .GE. 

RHOMIN) 

GO 

TO 

623 

IF 

<  FRHOVX  .GE. 

RHOMIN  ) 

GO 

TO 

623 

IF 

(TRODIF  .GE. 

DIFMIN  ) 

GO 

TO 

623 

IF 

( FRO  DIF  .GE. 

DIF  MIN  ) 

GO 

TO 

623 

GO  TO  209 

IIBKMR  =  IHEADRC  2  > 

JDAY  a  IHEABR( 3  ) 

JHOUR  =  IHEADRC  4) 

JSEC  =  IH£ABR(  5  ) 

IERRTQ  =  IHEADRC 17) 

IZERON  =  IHEADRC 18  ) 

IOVRNG  =  IHEADRC 19  ) 

IUNDRN  =  IHEADRC  20  ) 

JFLAG  =  IZERO 

CALL  RTCLQK.  (JFLAG,  AMONTH,  JO  AY  *  JHOUR, JH IN  » JSEC  ) 

IPFLAG  =  I HO 
IEFLAG  =  IMO 

IF  (ARRNBR  .EQ.  FOUR)  GO  TO  605 
IF  (  TRODIF  .LT.  -0.1)  GO  TO  641 
IF  (  STATS  .NE.  YES)  GO  TO  610 

IF  (  (  TRHGUG  .GE.  RHOMIN  )  .OR. C TRODIF .GE.DIFMIN  ) )  GO  TO  609 
IF  (TRHOVX  .LT.  RHOMIN  )  GO  TO  605 
GO  TO  604 

TYPE  1 1  ,  TRODIF  » I IBKNR  i  THREE  i  JDAY  ,  AMONTH  ,  JYEAF:  *  JHOUR  » JMI N » JSEC 
GO  TO  605 

IF  <  1 1ST  AT  -  0  )  601,663,606 
TYPE  130, THREE 
GO  TO  604 

IF  ( TRHOOG . GE . RHOMIN )  GO  TO  661 
IF  < TROUIF.LT. D IFHIN)  GO  TO  604 
IF  C TOELOX  .LT.  VELMIN)  GO  TO  605 
IF  <  TUELOX  .GT.  VELMAX  )  GO  TO  605 
TAZINY=TAZIMX 

IF  ((AZMIN.LT.O.  ) . AND . ( TAZI NX . GT . AZMINP  )  )  TAZIMY=TAZIMX-360 . 

IF  ( ( TAZIMY  .LT . AZMIN  )  .OR. ( TAZIMY ,GT .AZN AX  )  )  GO  TO  604 

IF  (ALL  .EQ.  YES)  GO  TO  651 

IF  <  IHEADRC  2 )  .EQ.  ISTART)  GO  TO  651 

IF  < IHEADR<  2  )  .EQ.  ISTOP  )  GO  TO  651 

GO  TO  610 

TYPE  198 , JDAY , AMONTH , JYEAR , JHOUR , JMIN , JSEC 
IPFLAG  =  I YES 

TYPE  133, IHEADRC 2  ) , I ZERO , T AZVAR , TVE VAR , TRHOVG , T AZ IMF , TOELOC , TROUT F 


noon 


604 


» 


r 


r 


t 


f 


» 


» 


» 


TYPE  197  * IIBKHR  * IERRT0, I ZEROH, IOVRNG, IUNDRN 
IEFLAG  =  IYES 
TYPE  137, THREE, TRHO 
DO  611,1  =  1,3 

611  TYPE  185, THREE »ITHAX< I  )»ITHIN< I  ),THU< I  ),TPSI< I  ),TSIGMA<  1  ) 

C 

610  IF  <  <  TRHOVX  .LT.  RHOMIN  ) , AND  .  <  TROD IF, LT .D1FMIN  >  )  GO  TO  605 
IF  (  ITSPQX  -  0)  612,613,614 

612  TYPE  192, THREE 
GO  TO  605 

C 

613  TYPE  180 
GO  TO  605 

C 

414  IF  < TVELOX  .LT.  VELMIH)  GO  TO  605 

IF  ( TUELOX  .GT.  VELMAX  )  GO  TO  605 

TAZIHY=TAZIHX 

IF  <  (  AZHIH.LT .0 ♦  )  *  AMD  .<  TAZIHX . GT . AZMINP  )  )  TAZIMY  =  TAZIMX-360 . 

IF  <(TAZIHY.LT. AZHI N  ) . OR. <  TAZIHY .GT . AZMAX  )  )  GO  TO  605 

IF  (ALL  .EQ.  YES)  GO  TO  652 

IF  < IHEADR(  2  )  . EQ.  ISTART  )  GO  TO  652 

IF  <IHEAHR<2)  .EQ.  ISTOP  )  GO  TO  652 

GO  TO  653 

652  IF  (  IPFLAG  .EQ.  IYES)  GO  TO  630 

TYPE  193,JOAY,AHOHTH,JYEAR,.JHOUR,.JMIM,JSEC 
IPFLAG  -  IYES 

630  TYPE  183,  IHEAlfR<2  ),  ITSPQX,  TAZVAX , TOEVAX > TRHOUX ,  TAZIHX,  TVELOX, 
6  TRODIF 
C 

653  ITNUM=ITMUH+1 
ITSET=ITSET+ITSPQX 
TCZT=TCZT+T  AZVAX 
TCVT=TCVT +TUEVAX 
TBRT=TDRT+TRODIF 
TAZT*TAZT+TAZIHY 
TVT=TUT+TOELOX 

IF  < TRT.LT.TRHOVX)  TRT=TRHOVX 
IF  < THDRT.LT. TROBIF  )  THORT=TRODIF 
C 

605  IF  (ARRNBR  .EQ.  THREE)  GO  TO  209 

IF  < IFRFLG  .EQ.  11)  GO  TO  20? 


F  array  signal  detection  area 

603  IDUH  =  IHEADR1  2  )  -  3 

IF  ( FRQDIF  .LT.  -0.1)  GO  TO  642 
IF  (STATS  .NE.  YES)  GO  TO  615 

IF  < ( FRHOOG  .GE,  RHOHIN  )  .0R,<  FRODIF .GE.DIFHIN ) )  GO  TO  621 
IF  (FRHOVX  .LT.  RHOMIR)  GO  TO  20? 

GO  TO  602 

642  TYPE  1 1 , FRODIF , IDUH , FOUR , JDAY , AHOHTH , J YEAR , JHOUR, JHIN , JSEC 
GO  TO  209 

621  IF  (IFSTAT  -  0  )  607,664,608 

607  TYPE  180, FOUR 
GO  TO  602 

608  IF  <  FRHOUG.GE . RHOHIH )  GO  TO  662 

664  IF  < FRODIF. LT.PIFHIN)  GO  TO  602 

662  IF  (FUELOX  .LT.  VELMIN  )  GO  TO  20? 

IF  <  FOELOX  .GT.  VELMAX  )  GO  TO  20? 


I 


noon 


FAZIrtY=FA2IKX 

IF  (  <  AZMIN . LT  .0  ) .  AND  ♦  <  FAZIMX . GT  .  A2MINP  )  )  FAZIMY=FAZIMX-360 . 

IF  <  <  FAZIMY  ,LT.  AZMIN).  OR. <  FAZIMY  ,  GT .  AZMAX  )  )  GO  TO  602 

IF  < ALL  .EQ.  YES  )  GO  TO  654 

IF  <IHEA0R<2)  .EQ.  1ST  ART  )  GO  TO  654 

IF  < IHEADR( 2  )  .EQ.  ISTOP  )  GO  TO  654 

GO  TO  615 

654  IF  < IPFLAG  .EQ.  IYES  )  GO  TO  631 

TYPE  193.  JDAY  » AMONTH, JYEAR  *  JHOUR..JMIN  >  .JSEC 
IPFLAG  =■  IYES 

631  TYPE  182. IBUN»IHEADR<  2  ) . I  ZERO . FAZVAR . FVEVAR » FRHQVG . FA7I MF . 

&  FVELOC » FROHIF 

C 

602  IF  « IEFLAG  .EQ.  IYES)  GO  TO  632 

TYPE  197 , IIBKNR. 1ERRT0* IZERON. IOVRNG. IUNBRN 

632  TYPE  181 » FOUR.FRHO 
DO  616.1  =  1.4 

616  TYPE  185 .FOUR*  IFMAX(  I  )» IFHIN<  I  >»F«U<  I  ),FF'SI(  I  ),FSIGMA(  I  ) 

C 

615  IF  << FRHOVX  ,LT.  RHOMIN  ) ,  AND .  (  FRDDIF  .LT. DIF MIN))  GO  TO  209 
IF  < IFSPQX  -  0)  617.618.619 

617  TYPE  192. FOUR 
GO  TO  209 

C 

618  TYPE  180 .FOUR 
GO  TO  209 

C 

619  IF  (FVELOX  .LT.  VELMIN)  GO  TO  209 

IF  <  FVELOX  .GT.  VELMAX  )  GO  TO  209 

FAZIMY=FAZIMX 

IF  ( (  AZMIN. LT.O.  ) .  AND  » <  FAZI MX . GT .  AZMINP  )  )  FAZI  MY=FAZ  I MX-360  . 

IF  ( (FAZIMY  .LT  . AZM IN  ) .  OR .  <  FAZIMY ,  GT  .AZMAX  )  )  GO  TO  209 

IF  (  ALL  .EQ.  YES)  GO  TO  655 

IF  ( IHEADR<  2  )  .EQ.  1ST ART  )  GO  TO  655 

IF  < IHEADR<  2  )  .EQ.  ISTOP)  GO  TO  655 

GO  TO  656 

655  IF  (IPFLAG  .EQ.  IYES)  GO  TO  633 

TYPE  198,.  JDAY,  AMONTH.. J  YEAR.  JHGUR..JMIN,. JSEC 

633  TYPE  182 , 1 BUM , IHEADR( 2  ) , IFSF'QX.FAZVAX ,  FVEVAX . FRHOVX »  FAZ I  MX , 

&  FVELOX.FRQDIF 

656  IFNUM=IFNUM+1 
IFSET  =  IFSE  T  +  IFSPQX 
FCZT =FC2T+FAZVAX 
FCVT =FCVT +FVEVAX 
FDRT=FDRT+FRODIF 
FAZT  =  FAZT  +FAZIMY 
FVT =FVT  +FVELOX 

IF  (FRT.LT. FRHOVX)  FRT=FRHOVX 
IF  <  FMDRT .LT  .FRODIF )  FMDRT=FROHIF 
GO  TO  209 


FORMATS  area 

10  FORMAT  </,'  AZ3CAN  Rev  7,') 

11  FORMAT  ('  Change  in  RHO  eoual 5 ' . F6 . 2 »5X » ' FI ocK  *'»I5»1X»A1» 

&  '  array  9'  ,13,"-'  » A3 » ' - '  .12,14,'  t '  ,12.13.’  "  Z  .  ) 

12  FORMAT  <A1) 

13  FORMAT  < '  F.T  or  »?  '  ,%) 

14  FORMAT  (F6.2) 


i 


o  o 


t 


» 


t 


? 


( 


15 

16 

17 

171 

172 

173 
175 

i 

177 

178 
17? 

18 
180 
181 
182 

{ 

183 

184 
135 
186 
187 
19 

190 

191 

192 

193 

194 

196 

197 

198 


FORMAT  ('  All?  '  **  ) 

FORMAT  ('  Statistics?  ',%) 

FORMAT  ('  BAH  Block*  #'*I5) 

FORMAT  ('  Minimum  CHANGE  IN  RHO?  M) 

FORMAT  ( 55X* ' ?ErrO  at  Block  *',I5> 

FORMAT  (40X,'?Err0  at  Block  *',I5) 

FORMAT  ( 14 » ' SIG  SE ' »F5 . 1 , 3X, ' MAXR' , F4 . 2 . 2Xt ' AVBR' , F4 . 2 . 2X , 

' MAXDR'  , F4 ♦ 2 ,3X* ' AZ '  ,F4.0*'  CZ '  *F4.Q*3X*'V'  ,F4»0,'  CV'  »F4.0> 


FORMAT  ('  Azimuth  MIN*MAXt  '$) 

FORMAT  <  2F6»2 ) 

FORMAT  ('  Velocity  MIN, MAXi  '$) 

FORMAT  ('  Minimum  RHO?  ',*) 

FORMAT  <'  '  *A1 »3X*  *  <<<INVALID  ANALYSIS!  ! %%%'  ) 

FORMAT  ('  ' *A1 »3X»6F5*2 ) 

FORMAT  < '  F' *16*'  to'  , 15 , 3X, 1 4 , 2F6 . 1  * 3X, ' ( '  , F4 *  2 » '  >'  , 2F8 . 2. 
16X*F5» 2  ) 

FORMAT  ('  T' *I6*11X*I4,2F6.1*19X*'('  *F4 . 2, '  )' , 2F3 . 2 , F5 . 2  ) 
FORMAT  <'  ' *A1 ,2X,6F5. 1 *F5,2 > 

FORMAT  < '  ' *  Ai  *  216 »  3F7  *  1 ) 

FORMAT  ('  ' ,A1»2X*3F6.2*12X,F5.2 ) 

FORMAT  ( '  ' *  Al  *  2X  *  3F5 • 2  > 

FORMAT  (216) 

FORMAT  ('  Start* Stop ;  '*$) 

FORMAT  ( / > 

FORMAT  ('  ' *A1,3X,'***INVALIB  FILTER'! #**'  ) 

FORMAT  < '  Year?  '  ,* ) 

FORMAT  ('  Timet' ,  13  * '  -' *  A3* ' -' *12*14*' t ' *12*'  ' 

FORMAT  (713) 

FORMAT  ('  ♦' ,516) 

FORMAT  ( '  &  WBA' ,13,'-' »A3,' ,12*14*' t'  *12*'  ' 


,  12, ' "Z??  '  ,$  ) 

*12,' "Z.'  ) 


♦  •♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦if 


500  STOP 
END 


♦ 


» 


> 


» 


t 


ODD 


C************  READ. FOR 
C 

C  Date  of  revision 

C 

PROGRAM  READ 


C 


*  **  ***************  %  *  ******  *  *#:*:#****  *  *  *  *****  *  * 
30-Sep-82 


C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


PURPOSE 

To  re-analyse  the  data  contained  on  a  tape. 

USAGE 

RUN  READ 

INPUT  PARAMETERS 

YEAR  -  A  two  digit  number 

Rev  4  -  The  revision  number  of  RTGAIU  by  which  the  tape  was 

recorded  < an  integer) 

TWEAK  -  The  twesK  factor  for  the  polarization  filter*  the 
larger  the  value*  the  more  enhanced  the  filter 
F*T*B  -  Selects  F  array*  T  array*  or  Both  arrays 

3  or  4  -  Selects  the  number  of  channels  in  the  F  array 

START  -  Integer  value  of  first  block  to  be  calculated 

STOP  -  Integer  value  of  last  block  to  be  calculated 

REMARKS 

To  have  valid  results*  the  value  of  START  must  be  at  least  four 
larger  than  the  block  number  of  the  tape's  current  position. 

It  takes  about  100  seconds  per  block  to  do  the  calculations . 

LIBRARIES  REQUIRED 

reblib*naclib,sy:forlib 

METHOD 

The  program  does  time  series  analysis*  polarization  filtering* 
and  time  series  analysis  < on  filtered  data)  in  the  same  manner 
as  the  RTGAIW  program. 

COMMON  /NTBLK/  IDNSTY . IPARTY * ISTATU( 12  ) 

COMMON  /IARRAY/  IHPING< 2163  ) * IBKRDY * ICHNL( 7  ) 

COMMON  /PASBLK/  IUKHDRC 20 ) » I4CHNLI 512*4  )  * I3CHNL<  512*3) 

COMMON  ZAP  ARAM/  FXDIF<  6  )*FYDIF<  6  )*FTDIF<  6  )  *  F5IGMA<  4  )*TXDTF(  3  )* 
CTYBIFC  3)*TTDIF(3  ),T5IGMA(  3  ) 

COMMON  /ANALYS/  IFSPQX*  FRHOVG*  FVELOC » FAZIMF  *  FVEVAR  *  FAZVAR . I FSTAT . 
CFMU<  4  )»FPSI<  4  )*FRH0<  6  )*IFMAX<  4  )*IFM.IN<  4  )  *  ITSF'QX *  TRHOUG * TUELOC  * 

( TAZIMF  »TUEUAR  »TAZVAR *  ITST AT  »  TMU<  3  >,TF'SI<  3  ),TRH0<  3  ),ITMAX<  3  )* 

CITNIN<  3  ) 

COMMON  /NISC/  ITMPRY(  1536  ),  IFCNBR*  I  ST  AT  *  1TAILR<  100).ITRGF:Y(  1??)* 

C  CALLER.*  INRBIF  *  INRCHL  ,  ITRMAX  *FIMGRY(  256*4  ) 

DIMENSION  IDMTBL(  12  ) 


DATA  IBMTBL/4 * 5*6*2»3»6*1*3*5* 1*2*4/ 

DATA  FXBIF/2406. *-5459. *-3685. , -7864 . * -6091 . ,1773./ 

DATA  FYDIF/-5658. *-3099. *1057. ,2559. ,6715. *4156.  / 

DATA  TXDIF/7 .6,-945 .8,-953 . 4/ ,TYDIF/-1 125 . 9 * -578 .5 ,547 . 4/ 
DATA  INBUFF/” 177562/, IMASK/" 177/,  I ADCSR/" 177000/ 

DATA  IGETDT/-1/ * IINTDT/0/ *F0UR/1HF/ *  THREE/ 1HT/ , DOTH/ 1HB/ 
DATA  XN0/1HN/ ,YES/1HY/ * IN0/-1/ , IYES/i/ * PIOVRN/ .0122719/ 
DATA  I UNIT/00/ * IDNSTY/800/ , IPARTY/1/ * IREU/-1/ 


Program  and  mag  tape  initialization  area. 
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c 

100 


c 

102 


» 


c 


c 


» 

11? 

c 

103 

> 

c 

107 


¥  C 


101 

c 

110 

112 


C 

10? 


I 

c 

105 


» 


c 


TYPE  10 
TYPE  193 
ACCEPT  19.JYEAR 

CALL  NTINIT< IUNIT  ) 

IF  (1ST ATIK  1  )  . NE .  IYES  )  STOP 

TYPE  16 

ACCEPT  14 1 IREVNR 

IF  <  IREVNR  .  LE »  9)  INRBYT  -•  4030 
IF  < IREUNR  .GE.  10)  INRBYT  =  4336 

TYPE  142 

ACCEPT  14  . ITWEAK 

IF  ( ITWEAK  .LE.  0)  ITWEAK  =  1 

RINDX  =  0. 

DO  119.1  =  1.129 

THETAN  =  COS< PIOVRN*RINDX > 

ITRGRY(I)  =  IFIX<  32767 . fcTHETAN  +  .5) 
RIMDX  =  RIMDX  +  1. 

TYPE  13 

ACCEPT  12  » ARRMBR 

IF  ( ARRNBR  .NE.  THREE)  GO  TO  107 

GO  TO  110 

TYPE  15 

ACCEPT  14  t IFCNBR 

IF  ( IFCMBR  .EQ.  4)  GO  TO  110 

TYPE  18 

ACCEPT  14 » IrtSCHL 

K  =  IMSCHL*3  +  1 

DO  101»I  =  1 » 3 

FXDIF(  I  )  =  FXDIF(  IDMTBL<  K ) ) 

FYDIF(  I  )  =  FYDIF(  IDMTBL(K)  ) 

K  =  K  +  1 

DO  112. K  =  1.1536 
ITMPRY(K)  *  0 
TYPE  190 

ACCEPT  19 . 1ST ART . ISTOP 
KSTART  =  ISTART  -  4 

CALL  REDTAPC IUMIT. IMPING. INRBYT. ISTATU ) 
IF  (ISTATU<1)  .EQ.  IYES)  GO  TO  105 
CALL  MTSTAT< IUNIT ) 

IF  <  ISTATIK  8 )  .EQ,  IYES)  GO  TO  108 
GO  TO  109 

IF  (  I NP I  NG<  2  )  .GE.  KSTART)  GO  TO  120 
IFWD  =  KSTART  -  INPING< 2  ) 

IFWD  =  IFUD  -  1 

IF  < IFWD  .EQ.  0)  GO  TO  10? 

CALL  SPCTAP  < IUNIT. IFUD, ISTATU  ) 

IF  <  ISTATIK  1  )  .EQ.  INO  )  STOP 
GO  TO  10? 


I 


nano  noon 


120  IF  (  I  HP  I NG(  2  >  .LE.  ISTOP)  GO  TO  104 
C 

108  PAUSE  '  ***D0NE***' 

GO  TO  110 

C 

104  CALL  REDTAP( I UNIT  » IUKHDR, INRBYT  » I STATU ) 
IF  < ISTATU< 1 >  .EQ.  IYES  )  GO  TO  111 
CALL  MTSTAT( IUNIT  ) 

IF  (1ST  ATU<  8  )  .  EQ .  IYES)  GO  TO  10S 
GO  TO  104 
C 

111  IF  (IUKHDR<2)  .NE.  IMPING<2))  GO  TO  114 

IF  (IUKHDR(4)  .ME.  IMPING*  4))  GO  TO  114 

TYPE  17  » IMPING<  2 ) 

C 

DO  117,1  =  1,2168 
117  IMPIMG< I  )  =  IUKHDR( I  ) 

GO  TO  104 
C 

114  CALL  SPCTAP<  IUNIT, IREV, ISTATU > 

IF  (1ST ATU( 1  )  .EQ.  IMO )  STOP 


Data  unwind  ares 

CALL  UNWIND  <  IMPING, I UKHDR* ITMPRY  ) 

IF  (IMPING*  2)  .LT.  ISTART  )  GO  TO  109 
IF  < IREUNR  .GE.  10)  GO  TO  600 
TYPE  141 
STOP 

T  array  analysis  area 

600  IIBKNR  =  IMPING<2) 

JDAY  =  I HP I NG<  3  ) 

JHOUR  =  IHPING<  4  ) 

•JSEC  =  I  HP  I  MC<  5  ) 

IERRTO  =  IMPING(  17 ) 

IZERON  =  IHPING< 18  ) 

IOVRNG  =  IHPING< 19) 

IUNDRN  =  IMPING<  20 ) 

C 

I  HP  I  NG<  18)  =  1TUEAK 
JFLAG  =  IINTDT 

CALL  RTCLOK  ( JFLAG , ANONTH, JDAY , JHOUR, JMIN , JSEC  ) 
TYPE  197 , I IBKNR, IERRTO, IZERON, IOVRNG, IUNDRN 
TYPE  198, JDAY, AMONTH,JYEAR, JHOUR, JMIN, JSEC 
C 

IF  <  ARRNBR  .EQ.  FOUR)  GO  TO  603 
ITSPQX  =  0 
CALLER  =  THREE 
CALL  RTGTDR 
C 

IF  (ITSTAT  .LT.  0)  GO  TO  605 

601  CALLER  =  THREE 
CALL  FILTER 

604  IF  (ITSPQX  .GT.  0)  GO  TO  606 
TYPE  192  tCALLER 
GO  TO  605 


I 


» 


t 


t 


» 


I 


> 


606  CALLER  =  THREE 
CALL  RTGTHR 

C 

605  IF  <  ARRNBR  .Eft.  THREE)  GO  TO  109 

C.... . . * . . . . . 

C 

C  F  array  analysis  ares 

C 

603  TYPE  191 

IFSPQX  =  0 
CALLER  =  FOUR 
CALL  RTGTDR 
C 

IF  < IFSTAT  »LT »  0)  GO  TO  109 

607  CALLER  =  FOUR 
CALL  FILTER 

603  IF  (IFSPQX  .GT.  0)  GO  TO  602 

TYPE  192, CALLER 
GO  TO  109 
C 

602  CALLER  =  FOUR 

CALL  RTGTDR 
GO  TO  109 

C».» . . . 

c 

C  FORMATS  area 

C 

10  FORMAT  </,'  READ  Rev  5.'  ) 

11  FORMAT  < '  ??»!') 

12  FORMAT  <  A1  ) 

13  FORMAT  (  '  F , T  or  B?  '  ,$ ) 

14  FORMAT  (312) 

141  FORMAT  ('  THIS  PROGRAM  WILL  NOT  READ  REVISIONS  LESS  THAN  10'  ) 

142  FORMAT  ('  PURFIL  Tweak  factor?  ',*> 

15  FORMAT  < '  3  or  4?  '  ,$ ) 

16  FORMAT  ('  REV  #?  ',$) 

17  FORMAT  ('  BAD  BlocK ,  *',I5> 

13  FORMAT  ('  Hissing  channel?  <0,1, 2, 3)  ',$) 

19  FORMAT  (216) 

190  FORMAT  ('  Start, SLopJ  ',*) 

191  FORMAT  </) 

192  FORMAT  (  '  '  ,A1  ,3X, '  #**INVALII<  FILTER!  !  #**'  ) 

193  FORMAT  ('  Year?  ',$) 

194  FORMAT  ('  Time ; '  ,  13 , ' ,  A3, ' ,  12, 1 4  , '  .* '  ,  12 ,  '  ',I2,'HZ??  '»*> 

195  FORMAT  ('  Correct  time?  <Y,H,D,H,M)  ') 

196  FORMAT  (713) 

197  FORMAT  </,'  *516  ) 

198  FORMAT  ('  @  WBA' ,13,'-' ,A3,' ,12,14,' { '  ,12,'  ',I2,'”Z.'> 

. . . . 

c 

500  STOP 

EHD 


» 


I 


nonooonnnnnonononnnnoonnnnnonnnnnonoonorjonooo  none 


^<***.44%.***  RP  l  SUN  .  r  UK  't**#*********'**********#*******#************* 

Date  of  revision!  4-Ngv-32 

PROGRAM  RPTSCN 

PURPOSE 

To  scan  s  tape  for  blocks  of  interest*  and  produce  sn  output  in 
the  form  of  s  data  message 


USAGE 

RUN  RPTSCN 


INPUT  PARAMETERS 

YEAR  -  A  two  didit  integer 
.JULIAN  -  A  three  digit  integer  Julian  das 
MONTH  -  A  three  letter  month  abbreviation 
DATE  -  A  two  digit  integer  date  of  month 
TIME  -  A  four  digit  integer 

SERIAL  -  A  four  digit  integer  (5000  <  SERIAL  <  50??) 

INF  NR  -  A  four  digit  integer 

F*T,B  -  Selects  F  array*  T  array*  or  Both  arrays 
RHOMIN  -  Minimum  average  correlation  coefficient  for  blocks  of 
interest  (default  0.7  if  T*  0.5  if  F) 

DIFMIN  -  Minimum  change  in  average  correlation  coefficient  after 
polarisation  filtering  (default  0.2) 

START  -  Integer  value  of  first  block  to  be  scanned 

STOP  -  Integer  value  of  last  block  to  be  scanned 

CONTNU  -  If  Y  is  entered*  program  will  allow  another  scan 
SKIP  PARAMS  -  Parameters  of  blocks  selected  by  A/SCAN  that  are 
not  to  be  listed  individually  in  the  report 
START  -  Integer  value  of  first  block  from  AZSCAN 

STOP  -  Integer  value  of  last  block  from  AZSCAN 

AZMIN  -  Real  value  of  minimum  azimuth  from  AZSCAN 

AZMAX  -  Real  value  of  maximum  azimuth  from  AZSCAN 

VELMIN  -  Real  value  of  minimum  velocity  from  AZSCAN 

VELHAX  -  Real  value  of  maximum  velocity  from  AZSCAN 


REMARKS 

To  prepare  a  data  message*  first  the  T  array  should  be  scanned* 
then  the  F  array  should  be  scanned.  If  an  EOF  < end-of-f i le )  is 
encountered  before  the  end  of  the  tape*  this  should  be  repeated. 


LIBRARIES  REQUIRED 

REDLIB*MACLIB*SY  JF0RLIB 


METHOD 

The  program  is  similiar  to  SCAN  and  AZSCAN  except  for  output 
format.  The  output  is  written  to  FTN19.DAT. 


COMMON  IMP0NG<  100)*  IBKBEGl  20)*IBKFIN<  20  )*AZMIN(  20  >*AZHAX(  20  ) 
COMMON  /MTBLK/  IDNSTY  * IPART Y  *  I STATU< 12  ) 

DIMENSION  UELMINI  20)*VELMAX<  20  )*IUKSF'C(  2163  ) 

COMMON  /TRAILY /  IHPING(  2068  )  * FVEL0C  * FAZIMF , FUEVAR .FAZVAR  * IFSTAT  * 
(  FMU<  4  )  tFPSIC  4  )*FRH0<  6  )*IFMAX(  4  ),IFMIN<  4  )  *  IFSPQX ,  FRHOt'X  ,  FUFt  OX, 

(  FAZIMX  » FVEVAX ,  FAZVAX  ,  TVEL0C »  T  AZ  IMF  *  TVE0AF: ,  TAZVAR  *  ITSTAT  ,  TMU<  3  )* 
CTPSI<  3  ),TRH0<  3  )*  ITNAX<  3  ),  ITMIN<  3  )*  ITSF'QX ,  TRHOVX, TVEL0X *  TAZIMX  , 

(  TVEUAX  »  TAZVAX 

DIMENSION  IKEADR<  20  ),  IHEAD2(  20  ),  I  HE  ADI  (  20  ) 

DIMENSION  FSIGMA<  4  ),TSIGMA( 3  > 


noon 


LUGICAL.il  1CHAR(  80  ),  ICHKCR,  ICHRLF  *  I CHRSP  *  ICHRC,  ICHRV 

DATA  IZERO/O/ ,  FOUR/  1HF/'  *  THREE/ 1 HT/ ,  B0TH/1HB/  ,  LINCNT/30/ 
DATA  XN0/1HN/,YES/1HY/, IN0/-1/, IYES/1/, I  LINE/ 1/ 

DATA  IUNIT/OO/  ,  IDNSTY/SOO/  ,  IPARTY/ 1/ , IREV/-1 / , I ILINE/O/ 


ProSrsm  snd  mss!  tef-e  ini tisl izstion  sres. 


» 


♦ 


9 


9 


» 


I 


» 


100  TYPE  10 
TYPE  193 
ACCEPT  19  *  JYEAR 
TYPE  172 

ACCEPT  1 9 ». JULIAN 
TYPE  173 

ACCEPT  191 » BNONTH 
TYPE  174 
ACCEPT  19.HDATE 
TYPE  175 
ACCEPT  19, MTINE 
TYPE  176 
ACCEPT  19 » NRSER 
TYPE  177 
ACCEPT  19 » INF NR 
C 

102  CALL  MTINIT( IUNIT  ) 

IF  ( ISTATU<  1  )  .ME.  IYES  >  STOP 
C 

PAUSE  "  Insert  wesssde  disk' 

WRITE  (  19, 130  ) 

WRITE  (  19, 131  )  NRSER, JUL IAN . MTINE , MDATE , MTI ME , BMDNTH , JYEAR 
WRITE  ( 19,132) 

WRITE  (19,133)  JYEAR, INFMR 
WRITE  <  19,184  ) 

C 

110  IGFLAG  =  INO 
TYPE  13 

ACCEPT  12*  ARRNBR 
C 

TYPE  18 

ACCEPT  14 , RHOMI N 
TYPE  171 

ACCEPT  14, DIFNIN 
IF  (RHONIN  » NE .  0.)  GO  TO  111 
IF  (ARRNBR  ,EQ.  THREE)  RH0MIN=0.7 
IF  (ARRNBR  .EQ .  FOUR)  RHOMIN=0.5 

IF  ((ARRNBR  ,NE.  THREE)  .AND.  (ARRNBR  .NE.  FOUR))  GO  TO  110 

111  IF  (DIFNIN  .EQ.  0.)  IUFMIN=0.2 
C 

KSKIP  =  -1 

115  KSKIP  =  KSKIP  +  1 
I  =  KSKIP  +  1 
ILINE  =  ILINE  +  1 
TYPE  16 

ACCEPT  161  ,  IBKBEG<  I  ),  IBKFIN(  I  >,AZMIN(  I  >,AZMAX<  I  ), 

&  OELNIN(  I  ),VELMAX(  I  ) 

IF  (VELNIN(I)  .EQ.  0.)  VELMIN(  I  >=250 . 

IF  (VELMAX(I)  . EQ  .  0.)  VELMAX(  I  )=700  . 

IF  (IBKBEG(I)  .NE.  0)  GO  TO  115 
ILINE  =  ILINE  -  1 


i 


I 


I 


o  n 


t 


f 


C  Tape  reed  sres 

C 

200  TYPE  190 

ACCEPT  19, I  START  » I ST OP 
1 1 STRT  =  1 

IF  (ARRNBR  .NE.  THREE)  IISTRT=4 
IF  (ISTART  .EQ.  0)  ISTART  =  IISTRT 
IF  (ISTOP  ,  EQ »  0)  I STOP  =  10000 
ISTOP  =  ISTOP  +  2 
C 

HO  243  , 1  =  2069  >2163 
243  IMPING!  I  )=0 

C 

209  DO  245,1  =  1,100 

II  =  I  +  206S 

245  IMPONG!  I  )=IMPING!  II  ) 

C 

IF  (  IGFLAG  .EQ.  IYES  )  GO  TO  201 

CALL  REHT AP< IUNIT  » IMPING, INRBYT  » ISTATU ) 

IF  !  ISTATU!  1)  .EQ.  IYES)  GO  TQ  205 
CALL  MTS  TATI  I UN IT  ) 

IF  (ARRNBR  .EQ.  THREE)  GO  TO  202 
IF  (1ST  ATLK  3  )  .EQ.  IYES)  ILINE  =  ILINE  4  1 
202  IF  (ISTATU(S)  .EQ.  IYES)  GO  TO  20S 
GO  TO  20? 

C 

205  IF  (IMPING!  2)  .EQ.  ISTART)  GO  TO  220 
IFUD  =  ISTART  -  IMPING! 2) 

IFWD  =  IFUD  -  1 

IF  (IFUD  .EQ.  0)  GO  TO  209 

CALL  SPCTAP  !  IUNIT, IFWD, ISTATU  ) 

IF  ( ISTATU!  1)  .EQ.  INO  )  STOP 
GO  TO  209 
C 

220  IF  (IMPING!  2)  .LE.  ISTOP)  GO  TO  204 
C 

208  PAUSE  '  ***DONE,  <CR>  TO  CONTINUE***DO  NOT  CTRL 
TYPE  15 

ACCEPT  12 , CGNTNU 
IF  (CONTNU  .NE.  YES)  GO  TO  700 
I HE ADR! 2  )  =  0 
IHEAD2! 2  )  =  0 
I HEAD  1! 2  )  =  0 
GO  TO  110 
C 

204  CALL  REDTAP!  IUNIT, IUKSPC, INRBYT, ISTATU  ) 

IF  ( ISTATU! 1)  .EQ.  IYES)  GO  TO  211 
CALL  MTSTAT( IUNIT ) 


IF 

(ARRNBR  .EQ 

.  THREE  )  GO  TO  206 

IF 

( 1ST ATU( 8  ) 

.EQ.  IYES)  ILINE  = 

ILINE  + 

206 

IF 

(  ISTATU!  8  > 

.EQ.  IYES)  GO  TO  2' 

03 

GO 

TO  204 

211 

IF 

(  IUKSPC!  2  ) 

.NE.  IMPING!  2  ) )  GO 

TO  214 

IF 

!  IUKSPC!  4  ) 

•  HE.  IMPING!  4  )  )  GO 

TO  214 

201 

DO 

217,1  =  1,2163 

» 


C*#*' 


noon 


217  IMPING*  I  )  =  IWKSF'C*  I  ) 

IGFLAG  =  INO 
GO  TO  204 

214  IGFLAG  =  IYE3 

IF  (IMPING*  2)  .  GT .  ISTOP)  GO  TO  203 


TsFe  bloci*  selu?'  snrf  TErrO  detection  s re 


300 


f  301 
C 


HO  301,1  =  1,20 
IHEADR* I >  =  IHEAD2* I ) 
IHEAII2*  I  )  =  IHEAD1*  I  ) 
IHEAD1  (  I  )  =  IMPING*  I  ) 


ITRFLG  = 
IFRFLG  = 


DO 

343,1  =  2153 

II 

=  I  -  2063 

343 

IF 

(  IMPING*  I  )  ,l 

IF 

(ITRFLG  .EQ. 

DO 

345,1  =  2114 

II 

=  I  -  2063 

345 

IF 

*  IMPING*  I  )  . 

IF 

(IFRFLG  .EQ, 

GO 

TO  34? 

347 

DO 

343,1  =  206? 

II 

=  I  -  2063 

343 

IF 

(  IMPING*  I  )  . 

Q.  IMPONG*  II)) 
11 )  GO  TO  347 


ITRFLG  = 


EQ.  IMPONG* II))  IFRFLG  = 
11)  TYPE  17, FOUR, I  HE ADR* 


.  IMPONG* II)) 
IF  (ITRFLG  .LT.  67)  GO  TO  34? 
TYPE  17  ,  THREE , I HE ADR*  2  ) 

GO  TO  20? 


ITRFLG  a 


*  C 


349  FRHOVG  =  0. 

DO  302,1  =  1,6 

302  FRHOL'G  =  FRHOVG  +  FRHO* I  ) 
FRHOUG  =  FRHOUG/6. 

TRHOVG  =  0. 

DO  303,1  =  1,3 

303  TRHOVG  =  TRHOVG  +  TRHO*  I  ) 
TRHOVG  =  TRHOVG/3 . 

TRODIF  =  TRHOOX  -  TRHOVG 
FROIHF  =  FRHOVX  -  FRHOVG 


C . 

IF 

GO 

(  IHEADR* 
TO  20? 

2)  . 

GE.  ISTART) 

GO 

TO  - 

C 

C 

T  i 

srrsy  sisnel 

detection 

sr 

es 

U 

600 

IF 

( TRHOVG 

.GE. 

RHOMIN ) 

GO 

TO 

602 

IF 

*  TRHOVX 

.GE. 

RHOMIN  ) 

GO 

TO 

602 

IF 

<  FRHOOG 

.GE. 

RHOMIN) 

GO 

TO 

602 

IF 

*  FRHOVX 

.GE, 

RHOMIN) 

GO 

TO 

602 

IF 

<  TRODIF 

.GE. 

DIFMIN  ) 

GO 

TO 

602 

IF 

*  FRODIF 

.GE. 

PIFMIN  ) 

GO 

TO 

602 

600 


GO  TO  20? 


60: 


I IBKNR  =  IHEADR*  2 ) 


I 


ITRFLG  +  1 


IFRFLG  +  1 
2  ) 


ITRFLG  -t-  1 


JHOUR  =  1HEADR( 4  ) 

JSEC  =  1HEADR(5> 

JFLAG  =  IZERO 

CALL  RTCLOK  (  JFLAG,  AHONTH , JDAY  ,  JHOUR  ,  JMI N  *  JSEC  ) 

KBAY  =  ICHOOZ(  JIlAY  ) 

JTIHE  =  JHOUR  *  100  +  JHIN 
KTIHE  =  ICHOOZ(  JTIHE  ) 

IF  ( ARRNBR  »  EG  .  FOUR)  GO  TO  605 

IF  ( ( TRHGUX  .GE.  RHOHI N ) . OR . < TRODI F . GE . BI FMI M > )  GO  TO  604 
GO  TO  605 

604  IF  <  TVELOX  .LT.  250.)  GO  TO  605 
IF  ( TUELOX  .GT.  700.)  GO  TO  605 

KSFLAG  =  INO 
KSKFLG  =  INO 

IF  (KSKIP  . LE .  0)  GO  TO  606 
DO  606  1=1, KSKIP 
KSKFLG  =  I YES 
AZHINP  =  AZMIN< I  ) 

IF  <  AZHIN( I  )  .GT.  AZHAX< I  ) )  AZHINP  =  AZMIN<  I  )  -  360. 

TAZIMY  =  TAZIMX 

IF  (  ( AZHINP . LT . 0  ). AND . ( TAZIHX . GT . AZHIN<  I > ) )  TAZ I MY=TAZI NY-360 . 


IF 

( IIBKNR 

.LT. 

IBKB£G(  I  )  )  KSKFLG  = 

INO 

IF 

( IIBKNR 

.GT. 

IBKF IN(  I  )  )  KSKFLG  = 

INO 

IF 

( KSKFLG 

.EQ. 

INO  )  GO  TO  606 

IF 

( TUELOX 

.LT. 

VELHIN(  I  )  )  KSKFLG  = 

INO 

IF 

( TUELOX 

.GT. 

VELHAX(I))  KSKFLG  = 

INO 

IF 

( TAZIHY 

.LT. 

AZHINP)  KSKFLG  =  I MO 

IF 

( TAZIHY 

.GT. 

AZHAX( I  )  )  KSKFLG  = 

INO 

IF 

( KSKFLG 

.EQ. 

IYES  )  KSFLAG  =  IYES 

CONTINUE 

IF 

( KSFLAG 

.EQ. 

I YES  )  GO  TO  605 

KTSPQX  =  ICHOOZ< ITSPGX ) 

KIBKNR  =  ICHOOZ( IIBKNR ) 

I  TAZ  =  IROUNDt  TAZIMX) 

KTAZ  =  ICHOOZ(ITAZ) 

ITCZ  =  IROUNIK  TAZVAX ) 

KTCZ  =  ICHOOZ(ITCZ) 

ITU  =  IROUNIK  TVELOX  ) 

ITCV  =  IROUNIK  TUEV AX  ) 

KTCV  =  ICHOOZ(ITCV) 

I LINE  =  ILINE  +  1 
IILINE  =  I ILINE  F  1 
KLINE  =  ICHOOZ( ILINE  ) 

C 

IF  (KLINE  -  0)  610:611,612 

610  WRITE  (18,401)  ILINE, THREE 

GO  TO  613 

61 1  WRITE  (18,402)  ILINE, THREE 

GO  TO  613 

612  WRITE  (13,403)  ILINE, THREE 

613  IF  (KTIHE  . GT .  1)  GO  TO  614 

IF  (KTIHE  -  0)  6131,6132,6133 

6131  WRITE  (18,404)  JTIHE 
GO  TO  615 

6132  WRITE  (13,4041)  JTIHE 


6133 

614 

615 

616 


t 


617 

618 
61? 


620 


621 


622 

623 

624 

625 

626 

627 

628 

t 

62? 

630 

631 

632 

♦ 

633 

634 

635 

636 
t 

637 

638 


#  63? 

C 

608 


» 


I 


(JO  TO  615 

WRITE  (  18.4042  >  JTIME 
GO  TO  615 

WRITE  <  18.405  )  JTIME 
IF  (KBAY  -  0)  616.617.617 
WRITE  (  18,406)  •  J D A Y , ANONTH 
GO  TO  618 

WRITE  (18,407)  JBAY.AMONTH 
IF  (KIBKNR  -  0>  619,620,621 
WRITE  (  18,408)  IIBKNR 
GO  TO  623 

WRITE  (  18,40?  )  IIBKNR 
GO  TO  623 

IF  (KIBKNR  .EG.  2)  GO  TO  622 
WRITE  (  18,410  )  IIBKNR 
GO  TO  623 

WRITE  (  18,411  )  IIBKNR 

IF  (  KTSF'GX  -  0)  624,625,626 

WRITE  (18,412)  ITSF'QX,  TRHOOX ,  TROD  IF 

GO  TO  627 

WRITE  (18,413)  ITSF'QX .TRHOOX , TROHIF 
GO  TO  627 

WRITE  (18,414)  I TSPQX , TRHOVX , TROB I F 
IF  (KTAZ  -  0)  628,629,630 
WRITE  ( 18,415)  ITAZ 
GO  TO  631 

WRITE  (  18,416  )  ITAZ 
GO  TO  631 

WRITE  ( 18,417 )  ITAZ 
IF  ( KTCZ  -  0)  632,633,634 
WRITE  ( 18,413)  I TCZ , ITV 
GO  TO  635 

WRITE  ( 18,41?)  I TCZ , ITV 
GO  TO  635 

WRITE  ( 18,420)  ITCZ.ITV 
IF  ( KTCV  -  0)  636,637,633 
WRITE  ( 13,421 )  ITCO 
GO  TO  608 

WRITE  (  18,422  )  ITCO 
GO  TO  608 

IF  ( KTCV  .EG.  2)  GO  TO  637 
WRITE  (  18,423  >  ITCV 
GO  TO  608 

WRITE  (  18,424  )  ITCO 

IF  (  I  LINE  .  LT  .  L.INCNT  )  GO  TO  605 

INFNRM  *  INF NR 

ILINE  =  ILINE  4  1 

NRSER  =  NRSER  4  1 

INF NR  =  INFNR  4  1 

MTIME  =  MTIME  4  10 

I ILINE  =  I ILINE  4  15 

LINCNT  =  LINCMT  4  80 

WRITE  (  18, 185) 

WRITE  ( 18,180) 

WRITE  (  18, 181 )  NRSER, JULIAN, MTIME, NHATE, MTIME, BMONTH, JYEAR 
WRITE  ( 18,132  ) 

WRITE  (18,133)  JYEAR, INFNR 
WRITE  (  18,184  ) 

IF  (LINCNT  ,GT .  200  )  GO  TO  6081 


noon 


«,u  il  \  io»  13;  >  xk-Ii'-ic.  »  0 ’C  thK  »  ii'tr  f’Ji.tl 

GO  TO  605 

6081  WRITE  (18,186)  ILINE , JYEAR , INFNRM 
605  IF  (ARRNBR  « EQ .  THREE)  GO  TO  209 
IF  < IFRFLG  .EQ.  11)  GO  TO  209 


F  array  signal  detection  ares 
603  I HUH  =  IHEADR(  2  )  -  3 

IF  ( ( FRHOVX  .GE.  RHOHIN ) . OR . < FRODIF . GE . BIFMI N ) )  GO  TO  607 
GO  TO  209 

607  IF  <  FVELOX  .LT.  250.)  GO  TO  209 
IF  <  FVELOX  .GT.  700.)  GO  TO  209 

*  C 

KSFLAG  =  INO 
KSKFLG  =  INO 

IF  ( KSKIP  .LE.  0)  GO  TO  609 
DO  609  I  =  1, KSKIP 
KSKFLG  =  I YES 

’  AZMINP  =  AZMIN( I  ) 

IF  (AZMIN(I)  .GT.  AZMAX(I))  AZMINP  =  AZMINC  I  )  -  360. 

FAZIMY  =  FAZIHX 

IF  <( AZMINP. LT.O). AND. ( FAZ IMX . GT . AZMIN<  I  )))  FAZ I MY=FAZIMY-360 . 
IF  (IIBKNR  .LT.  IBKBEG(I))  KSKFLG  =  INO 
IF  (IIBKNR  ,  GT .  1BKFIN(I)>  KSKFLG  =  INO 
f  IF  (KSKFLG  .EQ.  INO)  GO  TO  609 

IF  (FVELOX  .LT.  VELMIN(  I  )  >  KSKFLG  =  INO 
IF  (FVELOX  .GT.  VELMAX(  I  > )  KSKFLG  =  INO 
IF  (FAZIMY  .LT.  AZMINP)  KSKFLG  =  INO 
IF  (FAZINY  .GT.  AZNAX< I  )  )  KSKFLG  =  INO 
IF  (KSKFLG  .EQ.  IYES )  KSFLAG  -  IYES 
609  CONTINUE 

IF  (KSFLAG  .EQ.  IYES)  GO  TO  209 
KFSPQX  =  ICHOOZ(  IFSPQX ) 

KDUM  =  ICHOOZ( IHUM) 

IFAZ  =  IROUNIK  FAZ  IMX  ) 

,  KFAZ  =  ICHOOZ(IFAZ) 

IFCZ  =  IROUNIK  FAZVAX  ) 

KFCZ  =  ICHOOZ( IFCZ ) 

IFV  =  IROUNIK  FVELOX ) 

IFCV  =  IROUNIK  FVEVAX  ) 

KFCV  =  ICHOOZ(IFCV) 

*  I LINE  =  ILINE  +  1 

I ILINE  =  IILINE  +  1 
KLINE  =  ICHOOZ( ILINE  ) 

C 

IF  (KLINE  -  0)  640,641,642 

640  WRITE  (18,401)  ILINE, FOUR 

I  GO  TO  643 

641  WRITE  (  13,402)  ILINE, FOUR 

GO  TO  643 

642  WRITE  (18,403)  ILINE, FOUR 

643  IF  ( KTIME  .GT,  1 )  GO  TO  644 
IF  (KTIME  -  0)  6431,6432,6433 

|  6431  WRITE  (13,404)  JTIME 

GO  TO  645 

6432  WRITE  (13,4041)  JTIME 

GO  TO  645 

6433  WRITE  (18,4042)  JTIME 


GO  IU  645 

644  WRITE  (13.405)  JTIME 

645  IF  <  KDAY  -  0)  646.647.647 

646  WRITE  (13.406)  JHAY.AMONTH 
GO  TO  648 

647  WRITE  (13.407)  JDAY , AMQNTH 

648  IF  (KBUM  -  0)  649.650.651 

649  WRITE  (13.408)  I HUM 
GO  TO  653 

650  WRITE  (18,409)  IKUM 
GO  TO  653 

651  IF  (NHUM  .EQ.  2)  CO  TO  652 
WRITE  (  18,410  )  IEiUM 

GO  TO  653 

652  WRITE  (  18,411 )  IDUM 

653  IF  (  KFSF'GX  -  0)  654,655,656 

654  WRITE  (18,412)  IFSPQX , FRHOVX , FRODIF 
GO  TO  657 

655  WRITE  (18,413)  IFSPQX, FRHOVX ,  FROIHF 
GO  TO  657 

656  WRITE  (13,414)  IFSPQX .FRHOVX , FRODIF 

657  IF  (KFAZ  -  0)  653,659,660 

658  WRITE  (  18,415  )  IFAZ 

GO  TO  661 

659  WRITE  (  18,416)  IFAZ 

GO  TO  661 

660  WRITE  (  18,417  )  IFAZ 

661  IF  ( KFCZ  -  0)  662,663,664 

662  WRITE  (18,418)  IFCZ.IFV 

GO  TO  665 

663  WRITE  (18,419)  IFCZ.IFV 

GO  TO  665 

664  WRITE  (18,420)  IFCZ.IFV 

665  IF  (KFCV  -  0)  666,667,668 

666  WRITE  (  13,421  )  IFCV 

GO  TO  670 

667  WRITE  (  18,422)  IFCV 

GO  TO  670 

668  IF  (KFCV  .EQ .  2 )  GO  TO  669 
WRITE  ( 18,423)  IFCV 

GO  TO  670 

669  WRITE  (18,424)  IFCV 

670  IF  ( ILINE  , LT .  LINCNT  )  GO  TO  209 
INFNRM  =  IMF NR 

ILINE  =  ILINE  +  1 
NR3ER  =  NRSER  +  1 
INFNR  =  INFNR  +  1 
MTIME  =  NT  I  ME  +  10 
I ILINE  *  I  ILINE  +  15 
LINCNT  =  LINCNT  +  80 
WRITE  ( 18,185) 

WRITE  ( 18,180) 

WRITE  (  18,131  )  NRSER,  JULIAN,  MTIME, MHATE.MTIME.BMONTH, JYEAR 
WRITE  (  18,182  ) 

WRITE  (18,183)  JYEAR.INFHR 
WRITE  <  18,184) 

IF  (LINCNT  .GT.  200  )  GO  TO  601 
WRITE  (18,137)  ILINE, JYEAR, INFNRM 
GO  TO  209 

601  WRITE  (18,186)  ILINE , JYEAR , INFNRM 


noon  noon 


GO  TO  20? 


Output  restructuring  sree 

700  REWIND  18 

ICHRBK  =  "100 
ICHRCR  =  ”137 
KCOUNT  =  0 
710  JCOUNT  =  0 

720  READ  (  18,425,END=730  )  ( ICHAR< J >,  J  =  1,73) 
730  IF  < I  CHARI 1  )  . EQ .  ICHRBK)  WRITE  (19,188) 
740  JCOUNT  =  JCOUNT  +  1 

IF  ( ICHAR( JCOUNT )  , EQ .  0)  GO  TO  710 
IF  ( ICHAR( JCOUNT  )  , NE .  ICHRCR)  GO  TO  740 
WRITE  (  19,425  )  (ICHAR(I),I  *  1, JCOUNT) 
KCOUNT  =  KCOUNT  +  1 

IF  (KCOUNT  ,GE.  IILINE)  GO  TO  750 

GO  TO  710 

750  WRITE  (  19,185 ) 

CALL  EXIT 


FORMAT s  sree 


I  10  FORMAT  (/,'  RPTSCN  Rev  5.') 

11  FORMAT  ( 5A1 0  ) 

12  FORMAT  < A1  ) 

13  FORMAT  (  '  F  ,  T  or  B?  '  ,$  ) 

14  FORMAT  (F6.2) 

15  FORMAT  ('  Continue?  ' ,$  ) 

f  16  FORMAT  ('  SKIP  PARAM3 1  START , STOP , A2MIM , A2MAX ,'  , 

&  ' VELMIN » VELMAX?  '  ,$  ) 

161  FORMAT  ( 2I6»4F 10.3  ) 

17  FORMAT  ('  ' ,  A1 , '  TErrO  st  BlocK  4',I5) 

171  FORMAT  ('  Minimum  CHANGE  IN  RHO?  ',$) 

172  FORMAT  ('  Julian  day?  '  «$  ) 

t  173  FORMAT  ('  Month?  ',$) 

174  FORMAT  ('  Date  of  month?  ',$> 

175  FORMAT  ('  Time  of  message?  ',$) 

176  FORMAT  ('  Serial  nr?  ',*) 

177  FORMAT  ('  Infrasonics  nr?  ',$> 

18  FORMAT  ('  Minimum  RHO?  ',$) 

»  180  FORMAT  (  '  \\_',/,'RR  RUEBALBW.') 

131  FORMAT  ('DE  RUHHWEB  ' ,314,' 3\\_ ' , / , ' ZNR  UUUUU\\_' ,/ , ' R' ,13,14, 

&  'Z  '  ,A3»I3,'\\_'  ,/,'FM  MCMURDO  STATION  ANT ARCT I CA\\_ '  ) 

182  FORMAT  ('TO  GEOPHYSICAL  INSTITUTE  FAIRBANKS  AN //TEL  EX  NR', 

&  '  35414//W-' ,/, '  ACCT  NS-WCAB\\_'  > 

183  FORMAT  (  '  BT\\_'  ,/, '  UNCLAS  INFRASONICS  MR'  ,  13, ' ,  14  , '  \\...'  ) 

»  184  FORMAT  ('PASS  TO  DR  C  WILSON\\_' , / , ' SUBJ t  INFRASONICS  REPORT\\_ 

185  FORMAT  ('REGARDS,  KAY\\_' ,  /  , '  BTW _ NNNN'  ,  / 

&  '  333333333  J  3333333333(?<?(?<?@i?<?<?<?<?(?<?<?t?G?@(?<?<?®'  ) 

186  FORMAT  ( 13, '  .CONTINUED  FROM  MSG  NR'  ,  13 ,  ' , 1 4 , ' \\_'  > 

187  FORMAT  ( 12 ,' .CONTINUED  FROM  MSG  NR '  ,  13 , ' - ' , 1 4 , ' \\ . '  ) 

183  FORMAT  (' _ NNNN33 3 3 3 3 3 3 3 3 3 3 1 3 3 3 3 3 3 3 ' , / , 

1?  FORMAT  (216) 

190  FORMAT  ('  StarUStoe:  '»$) 

191  FORMAT  (A3) 

193  FORMAT  ('  Year?  '  ,$  ) 


» 


196 

FORMAT 

(713  ) 

401 

FORMAT 

< lit '  ♦' »A1»'  t'  ,$  ) 

402 

FORMAT 

( 12 » ' »  ai  » ' ,$  > 

403 

FORMAT 

(  13  * '  ,A1*'  »*> 

404 

FORMAT 

( '000' ,I1»'Z  '  ,4  ) 

4041 

FORMAT 

< '00' »I2»'Z  '  ,*> 

4042 

FORMAT 

( ‘O'  , 13 » ' Z  '  ,*) 

405 

FORMAT 

<  14, 'Z  '  ,4  ) 

406 

FORMAT 

<IliA3ilXr$> 

407 

FORMAT 

( 12, A3» IX, $ ) 

408 

FORMAT 

(  '  BK'  ill, IX, 4  ) 

409 

FORMAT 

< 'BK' , 12 , 1 X »  4  ) 

410 

FORMAT 

( 'BK'  ,  13, IX, $  ) 

411 

FORMAT 

( 'BK'  ,14, IX, $  ) 

412 

FORMAT 

('SE' ,11,'  R '  , F  4 . 2 , '  DR' »F4 . 2, IX, 4  > 

413 

FORMAT 

(  '  SE'  ,  12  , '  R'  , F4  ♦  2, '  DR'  ,F4 . 2 ,  IX,  $  > 

414 

FORMAT 

< ' SE ' , 13 , '  R'  ,F4 . 2, '  PR'  ,F4»2,1X,4) 

415 

FORMAT 

( 'AZ' ,I1,1X,$  ) 

416 

FORMAT 

< 'AZ'  ,  1 2 » 1 X ,  4  ) 

417 

FORMAT 

( ' AZ'  ,13, IX, $  ) 

418 

FORMAT 

( 'CZ' , 11,'  V' ,  13, IX, $  ) 

419 

FORMAT 

('CZ'  ,12, '  V'  ,  1 3  » i X »  $  ) 

420 

FORMAT 

( 'CZ'  ,13,'  V'  ,13, IX, 4  ) 

421 

FORMAT 

( 'CV' ,I1,'\\_'  ) 

422 

FORMAT 

( 'CV'  ,  12 , ' \\_ '  ) 

423 

format 

( 'CV'  ,  13, ' \\_'  ) 

424 

FORMAT 

( 'CV' , 14 , ' \\_ ' ) 

425 
r . 

FORMAT 

( 30A1  ) 

C 

500 

STOP 

END 

c 

c 

c 

c 

FUNCTION  ICHOOZ(IVAL) 

C 

C  PURPOSE 

C  To  determine  the  number  of  digits  in  5  positive  integer 

C 

C  USAGE 

C  ICHOOZ< IVAL  ) 

C 

C  INPUT  PARAMETERS 

C  IVAL  -  The  integer  value  to  be  tested 

C 

C  REMARKS 

C  IVAL  must  be  s  positive  integer  less  then  10,000 

C 

C  METHOD 

C  The  number  of  digits  in  the  inp-ut  velue  is  determined 

C  and  ICHOOZ  is  set  such  that  ICHOOZ  =  ( *  of  digits)  -  2. 

C 
C 

ICHOOZ  =  -l 

IF  < IVAL  *GE ♦  10)  ICHOOZ  =  0 
IF  (IVAL  .  GE .  100)  ICHOOZ  =  1 
IF  (IVAL  .CE.  1000)  ICHOOZ  =  2 
RETURN 


u  u  u  u  uuuuuuuuuuUuuuuuu 


FUNCTION  IROUNIK  REAL) 

PURPOSE 

To  round  off  s  re si  vslue 
USAGE 

IROUNIK  REAL  ) 

INPUT  PARAMETERS 

REAL  -  The  reel  nuniber  to  be  rounded  off 

REMARKS 

None 

METHOD 

The  reel  velue  is  increesed  by  0*5  end  then  trunceted* 


REAL  =  REAL  +  0.5 
IROUNIi  =  INT(  REAL  ) 
RETURN 
END 


I 


> 


» 


o  o  n  o 


l,*****X***XX* 

C 


SCAN. FOR  ***X##**£###*#*XX*#****#X##**X**#:*#:#:**#***##:*. 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


Dale  of  revision;  4-Nov-82 


PROGRAM  SCAN 


PURPOSE 

To  seen 


s  tape  for  blocks  of  interest 


USAGE 

RUN 


SCAN 


INPUT  PARAMETERS 


YEAR 

F*T*B 

RHOMIN 


STATS  - 

START  - 
STOP 


A  two  digit  integer 

Selects  F  array*  T  array*  or  Both  arrays 
Minimum  average  correlation  coefficient  for  blocks  of 
interest 

DIFMIN  -  Minimum  change  in  average  correl eti on  coefficient  after- 
polar  ization  filtering 

If  Y  is  enteredi  statistics  will  be  printed  for  each 
block  of  interest 

Integer  value  of  first  block  to  be  scanned 
Integer  value  of  lest  block  to  be  scanned 


sk i peed  an d  shou  1  d 


REMARKS 

When  an  ?Er-rO  is  encountered*  that  block  is 
be  read  by  program  READ  to  recover  lost  data 

LIBRARIES  REQUIRED 

redlib*maclib*sy:fof:lib 

METHOD 

The  program  scans  the  trailer  data  of  the  tare  starting  at  START* 
If  the  value  of  RHO  is  greater  than  RHOiHIN  or  the  change  in  RHO 
is  greater  than  RIFMIN*  then  the  analysis  data  (and  statistics  if 
reouested  )  ere  printed.  When  an  EOF  ( end-of-fi le  )  or  the  STOP 
block  is  encountered*  the  program  then  allows  for  another  scan, 

DIMENSION  IMFONG(IOO) 

COMMON  /MTBLK/  IDNSTY . IPARTY * ISTATU(  12 ) 

DIMENSION  IWKSPC<  2168 ) 

COMMON  /TRAILY/  IMPING<  2068  )  *  FVELOC  *  FAZI MF  »  FVEUAR » F  AZVAR  « IFST  AT  » 
i  FMU( 4  )»FPS1<4  )  »FRH0< 6  ),IFHAX< 4  >*IFMIN<  4  ) , I FSPQX * FRHOVX > FUEL  OX . 

CFAZIMX  »Ft'EUAX»FAZVAX »  TVELOC *  T  AZIMF  *  TVEVAR*  TAZt'AR*  ITSTAT  *  TMIK  3  >* 

CTPSK  3  )» TRUCK  3  ).  ITMAX<  3  ).  1TMIN<  3  )  *  ITSF'QX  *  TRHOUX  *  TUELOX.  *  TAZ I  MX  * 
CTVEVAXtTAZUAX 

DIMENSION  IHEADR(  20  ),  IHEAD2(  20  )  *  IHEADK  20  ) 

DIMENSION  FSIGMA(  4  >*TSIGMA(  3  ) 

DATA  I ZERO/O/ *  FOUR/ 1HF / *  THREE/ 1 HT/ *  DOTH/ 1 HD/ 

DATA  XN0/1HN/ * YES/1HY/ *IN0/-1/*IYES/1/ 

DATA  I  UNIT/ 00/  *  IDNSTY/ 800/  * IPARTY/1/  *  IF;EL'/-1/ 


Program  end  mag  tape  initialization  area, 

»  100  TYPE  10 

TYPE  193 
ACCEPT  19* JYEAR 


o  o  n  o 


102  CALL  HTIHITt IUNIT  ) 

IF  < 1ST ATU< 1 >  .NE.  IYES)  STOP 
C 

110  IGFLAG  =  INO 
TYPE  13 

ACCEPT  12  *  ARRNBR 
C 

TYPE  18 

ACCEPT  14, RHOHIN 
TYPE  171 

ACCEPT  14,DIFHIN 
IF  (RHOHIN  . NE .  0.)  GO  TO  111 
IF  (ARRNBR  .EG.  THREE)  RHOHIN  =  0.7 
IF  (ARRNBR  .EG.  FOUR)  RHOHIN  =  0.5 

IF  ((ARRNBR  .NE.  THREE)  .  ANIi  ♦  (ARRNBR  .  NE .  FOUR))  GO  TO  110 

111  IF  (ItIFNIN  .EQ.  0.)  DIF  HIN  =  0.2 
C 

TYPE  16 

ACCEPT  12* STATS 


Tape  read  area 

200  TYPE  190 

ACCEPT  19* I START  *  I STOP 
IF  ( ISTART  .EO.  0)  ISTART  =  1 
IF  (  I STOP  .EQ.  0)  ISTOP  =  10000 
I STOP  =  ISTOP  +  2 
C 

DO  243,1  =  2069,2168 
243  1HPING(I)=0 

C 

209  BO  245.1  =  1.100 

II  =  I  +  2068 

245  INPONG(  I  )=INPING(  II  ) 

C 

IF  (IGFLAG  .EQ.  IYES)  GO  TO  201 
CALL  REBT  AP(  IUNIT,  IHF'ING,  INRBYT  *  I  STATU  ) 
IF  (  ISTATIK  1  )  .EQ.  IYES)  GO  TO  205 
CALL  HTSTAT( IUNIT ) 

IF  (  ISTATU<  8 )  .EQ.  IYES)  GO  TO  208 
GO  TO  209 
C 

205  IF  (  IHF’I  NG(  2  )  .EQ.  ISTART)  GO  TO  220 
IFUIi  =  ISTART  -  IHP1NG<2) 

IFUIi  =  IFWB  -  1 

IF  ( IFWB  .EQ.  0)  GO  TO  209 

CALL  SPCTAP  ( IUNIT, IFWB, ISTATU) 

IF  (ISTATU(l)  .EQ.  INO)  STOP 
GO  TO  209 
C 

220  IF  (  INF’ING(  2  )  .LE.  ISTOP)  GO  TO  204 
C 

208  PAUSE  '  ***DONE***' 

IHEABR(  2  )  =  0 
IHEAD2<  2  )  =  0 
IHEADH  2  )  =  0 
GO  TO  110 
C 

204  CALL  REBTAP(  IUNIT,  IWKSF’C*  INRBYT,  ISTATU  ) 


o  o  n  o 


c 

211 


C 

201 

217 


C 

214 


IF  (ISTATUd)  < EG » 
CALL  NTSTAT< IUH2T  ) 
IF  (  ISTATIK  8  )  . EG , 
CO  TO  204 


IYES )  GO  TO  211 


I  YES )  GO  TO  208 


IF  <iyKSF’C<2)  .NE.  IMPING<2>>  GO  TO  214 
IF  (  IUKSF'C<  4  )  .NE.  IHPING(4>)  GO  TO  214 
TYPE  17  » IMPING*  2) 


DO  217  , I  =  1,2168 
IKPING<  I  )  =  IWKSF'Ct  I  ) 

IGFLAG  =  INO 
GO  TO  204 

IGFLAG  =  IYES 

IF  (  I  HF‘  I NG(  2  )  .GT.  ISTOP  )  GO  TO  208 


T3f>e  biocK  Seims'  snd  TErrO  detection  sres 

300  DO  301,1  =  1,20 
IHEADR<  I  )  =  IHEAD2(  I  ) 

IHEAD2C  I  )  =  IHEADH  I  > 

301  IHEADl(I)  =  INFING<  I  ) 

C 

ITRFLG  =  0 
IFRFLG  =  0 


DO 

343,1  =  2158,2168 

II 

=  I  -  2068 

343 

IF 

(INPING(I)  .EQ.  IMPONG(II)) 

ITRFLG  = 

ITRFLG 

+ 

1 

IF 

< ITRFLG  .EQ.  11 )  GO  TO  347 

DO 

345,1  =  2114,2124 

II 

=  I  -  2068 

345 

IF 

(IMPING(I)  .EQ.  IMPONG(II)) 

IFRFLG  = 

IFRFLG 

+ 

1 

IF 

(IFRFLG  .EQ.  11)  TYPE  173, IHEADRt 2 ) 

GO 

TO  34? 

347 

DO 

348,1  =  2069,2124 

II 

=  I  -  2068 

348 

IF 

(IMPING*  I)  .EQ.  IMPONGUI  >> 

ITRFLG  = 

ITRFLG 

+ 

1 

IF 

(ITRFLG  .LT.  67)  GO  TO  349 

TYPE  172 , IHEADR(  2 ) 

GO  TO  20? 

C 

349  FRHOVG  =  0. 

DO  302,1  =  1,6 

302  FRHOVG  =  FRHOVG  +  FRHO< I  ) 

FRHOVG  =  FRHOVG/6 . 

C 

DO  304,1  =  1,4 

FSIGMA(I)  =  FPSI<I)**2  -  FNU<  I  )tt2 
IF  (FSICNA(I)  .LT.  0.)  FSIGHAd  )  =  0. 
304  FSIGMAt I  )  =  SQRTt FSI GMA< I  )  > 

C 

TRHOVG  =  0. 

DO  303,1  =  1,3 

TSIGMA(I)  =  TPSI(I>**2  -  THU<  I  )**2 
IF  (TSICMA(I)  .LT.  0.)  TSIGMAU  >  =  0. 
TSIGHAl I  )  =  SQRT( TSIGNAC I  ) ) 

C 

303  TRHOVG  =  TRHOMG  +  TRHO( I  ) 


o  o  n  o 


TRHOVG  =  TRHOVG/3. 

TRODIF  =  TRHOVX  -  TRHOVG 
F ROD IF  =  FRHOVX  -  FRHOVG 


C 

IF  (  IHEADR(  2  >  .  GE .  ISTART  )  GO  TO  600 
GO  TO  209 


T  srrsy  sisinsl  detection  sres 

600  IF  (TRHOVG  .GE.  RHOMIN)  GO  TO  623 
IF  ( TRHOVX  .GE.  RHOMIN)  GO  TO  623 
IF  (FRHOVG  .GE.  RHOMIN)  GO  TO  623 
IF  ( FRHOVX  .GE.  RHOMIN)  GO  TO  623 
IF  ( TROD IF  .LT.  -0.1)  GO  TO  623 
IF  ( FRODIF  .LT.  -0.1)  GO  TO  623 
IF  ( TRODIF  .GE.  DIFM1N )  GO  TO  623 
IF  (FRODIF  .GE.  PIFMIN)  GO  TO  623 
GO  TO  209 

C 

623  IIBKNR  =  IREADR(  2  ) 

JDAY  =  IHEADR(  3 ) 

JHOUR  =  IHEADR(  4  ) 

JSEC  =  IHEADR(S) 

IERRTO  =  IHEADR( 17 ) 

IZERON  =  IHEADR(  18 ) 

IOVRNG  =  IHEADR(  19 ) 

IUNDRN  =  IHEADR(  20 ) 

C 

JFLAG  =  IZERO 

CALL  RTCLOK  (JFLAG,  AMONTH » JDAY » JHOUR  *  JMI N » JSEC  ) 

IPFLAG  =  INO 
IEFLAG  =  INO 
C 

IF  (ARRNBR  .EG.  FOUR)  GO  TO  605 

IF  (TRODIF  .LT.  -0.1)  GO  TO  641 

IF  (STATS  .NE.  YES)  GO  TO  610 

IF  ((TRHOVG  .GE.  RHOMIN ). OR .< TRODIF . GE . DIFKI N  ) )  GO  TO  609 
IF  (TRHOVX  .LT,  RHOMIN)  GO  TO  605 
CO  TO  604 

641  IF  (STATS  .EG.  YES)  GO  TO  661 

TYPE  1 1 , TRODIF , 1 IBKNR, THREE , JDAY  *  AMONTH  >  JYEAR, JHOUR, JMIN ,  JSEC 
GO  TO  605 

609  IF  ( ITSTAT  -  0)  601.663.606 

601  TYPE  180, THREE 
GO  TO  604 

606  IF  ( TRHOVG. GE. RHOMIN  )  GO  TO  661 

663  IF  ( TRODIF. LT.DIFNIN  )  GO  TO  604 

IF  (TVELOX  .LT.  250.)  GO  TO  605 

IF  (TVELOX  .GT.  700.)  GO  TO  605 

661  TYPE  198, JDAY, AMONTH. JYEAR. JHOUR, JMIN, JSEC 

IPFLAG  =  IYES 

TYPE  183»IHEADR( 2), I  ZERO, TAZVAR. TVEVAR, TRHOVG , TAZIHF , TVELOC, TRODIF 
C 

604  TYPE  197, 1  IBKNR,  IERRTO,  IZERON,  IOVRNG,  IUMIIRM 
IEFLAG  =  IYES 
TYPE  187, THREE, TRHO 
DO  611,1  =  1,3 

TYPE  185, THREE, ITMAX(  I ), ITMIN(  I  ),TMU(  I  ),TPSI(  I ),TSIGMA< I  ) 


611 


noon 


610 


IF  (  <  TRHOVX  .LT.  RHOMIN  ). ANB .( TROBI F . LT . H1FMI N ) )  GO  TO  605 
IF  (ITSPQX  -  0)  612*613.614 

612  TYPE  192. THREE 
GO  TO  605 

613  TYPE  180 
GO  TO  605 


614 

IF 

( TVELOX  .LT.  250.  ) 

GO 

TO 

605 

IF 

(TVELOX  .GT.  700.  ) 

GO 

TO 

605 

IF 

(IPFLAG  .EQ.  IYES) 

GO 

TO 

630 

TYPE  198 . JDAY , AMONTH . JYEAR » JHOUR. JMI N . JSEC 
IF'FLAG  =  I  YES 

630  TYPE  183. IHEAOR( 2 ) .  ITSPQX , T AZVAX » TVEVAX . TRHOVX. T AZIMX, TVELOX, 
&  TROD IF 

605  IF  (ARRNBR  .EQ.  THREE)  GO  TO  209 
IF  (1FRFLG  .EQ.  11)  GO  TO  209 


F  3rrsy  signal  detection  ares 

603  I HUM  =  IHEAHR(  2  )  -  3 

IF  (FROHIF  .LT.  -0.1)  GO  TO  642 
IF  (STATS  .NE.  YES)  GO  TO  615 

IF  ( ( FRHOVG  .GE.  RHOMIN  ) . OR . ( FROHIF . GE . DIFNI N  ) )  GO  TO  621 
IF  <  FRHOVX  .LT.  RHOMIN)  GO  TO  209 
GO  TO  602 

642  IF  (STATS  .EQ.  YES)  GO  TO  662 

T YFE  1 1 . FROHIF . IHUM , FOUR . JDAY . AMONTH . JYEAR . JHOUR » JMI N , JSEC 
GO  TO  209 

621  IF  < IFSTAT  -  0)  607 . 664 , 608 

607  TYPE  180. FOUR 
GO  TO  602 

608  IF  (  FRHOVG. GE. RHOMIN  )  GO  TO  662 

664  IF  (  FROHIF. LT.HIFMIN  )  GO  TO  602 

IF  (  FVELOX  .LT.  250.)  GO  TO  209 
IF  ( FVELOX  .GT.  700.)  GO  TO  209 
662  IF  (  IPFLAG  , EQ.  IYES  )  GO  TO  631 

TYPE  198 . JHAY , AMONTH . JYEAR . JHOUR. JMI N .JSEC 
IPFLAG  =  IYES 

631  TYPE  182.  IHUM.  IHEADR(  2  )>  I  ZERO . FAZ VAR .  FVEVAR .  FRHOL'G.  FAZI MF  . 
6  FVELOC, FROHIF 

C 

602  IF  ( IEFLAG  .EQ.  IYES)  GO  TO  622 

TYPE  1 97 . 1 IBKNR » IERRTO  > 1 2ER0N . I OVRNG . I UNHRN 

632  TYPE  181 .FOUR, FRHO 
HO  616,1  =  1.4 

616  TYPE  185,  FOUR.  IFMAX(  I  ),IFMIN<  I  ),  FMU(  I  )» FF’SI(  I  )»  FSIGMA(  I  ) 

C 

615  IF  ((FRHOVX  .LT.  RHOMIN ). AND .( FROHIF . LT . HIFMIN  )  )  GO  TO  209 
IF  ( 1FSPQX  -  0)  617,618,619 

617  TYPE  192 .FOUR 
GO  TO  209 

C 

618  TYPE  180, FOUR 
GO  TO  209 

C 

619  IF  (FVELOX  .LT .  250.)  GO  TO  209 

IF  (FVELOX  .GT.  700.  )  GO  TO  209 


I 


n  o  o  o 


IF  <  IPFLAG  .EG.  IYES >  GO  TO  633 
TYPE  1 98 » JDAY  ,  AHDNTH » J YEAR ,  JHOUR.  JMIN » .JSEC 
633  TYPE  182.IHUM*IHEAHR< 2 ) , I FSPGX , F AZL'AX t F OEUAX * FRHOL'X, F AZI MX . 


{. 

FVELOX , 
GO  TO  2 

FROM  F 

09 

FORMATS 

area 

10 

FORMAT 

( /,'  SCAN  Rev  5.'  ) 

11 

FORMAT 

('  Change  in  RHO  equals' , F6. 2* 5X, ' F) ock  *'fI5»lX»Al, 

& 

'  array  <?  '  , 13. ' ,  A3. ' -'  ,  12. 14  * '  :  '  , 12.  13* '  "Z. '  ) 

12 

FORMAT 

( A1  ) 

13 

FORMAT 

(  '  F  » T  or  FT  '  ,$  > 

14 

FORMAT 

(F6.2) 

16 

FORMAT 

< '  Stati sties?  '  » t ) 

17 

FORMAT 

(  '  BAG  FlocK ,  , 15 ) 

171 

FORMAT 

('  Minimum  CHANGE  IN  RHO?  ',*) 

172 

FORMAT 

( 55X, ' TErrO  at  FlocK  *',I5) 

173 

FORMAT 

( 40X  » '  TErrO  at  FlocK  *'»I5) 

18 

FORMAT 

('  Mininium  RHO?  '»$) 

180 

FORMAT 

('  '  ,A1 »3X, '  ***INVALII<  ANALYSIS!!***') 

181 

FORMAT 

('  '  ,A1 .3X.6F5.2 > 

182 

FORMAT 

('  F  '  ,  16 , '  to'  , I5.3X, I4.2F6. 1 »3X, '  (  '  ,F4.2, '  >'  ,2F8.2 

& 

16X.F5. 

.2  ) 

183 

FORMAT 

('  T' ,16. 11X, I4.2F6. 1 , 19X, '< ' »F4 .2,'  )' , 2F8 . 2 . F5 . 2  ) 

184 

FORMAT 

('  '  ,A1 »2X»6F5.1»F5.2) 

185 

FORMAT 

(  '  '  * A1 *  216 »  3F7 . 1  ) 

186 

FORMAT 

('  '  .A1.2X.3F6.2. 12X.F5.2 ) 

187 

FORMAT 

('  '  ,A1 .2X.3F5.2 ) 

19 

FORMAT 

(216  ) 

190 

FORMAT 

('  Start. Stop  1  '.$) 

191 

FORMAT 

(  /  ) 

192 

FORMAT 

('  '  ,A1 ,3X, '  ***INVALIIi  FILTER!!***') 

193 

FOFiMAT 

('  Year?  '»*) 

194 

FORMAT 

('  Timet ' .13. ' .A3.' .12.14.' : '  ,  12, '  ',I2,'BZ??  ' 

196 

FORMAT 

(  713  ) 

197 

FORMAT 

('  *' ,516 ) 

198 

FORMAT 

('  P  WFA'  ,13,'-'  ,A3,'-'  .12,14,".'  .12,'  ',I2,'"Z.') 

C 

500  STOP 
END 


I 


I 
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C*#****####**  SCNTWK.FOR  #**)»:#*!»:)t5t#**)t:**3»:******#***»*>t:#*****Jt:********* 
list©  of  revision:  30-Sep-82 


PROGRAM  SCNTWK 
PURPOSE 

To  re-snalyze  the  data  contained  on  a  tape  with  the  polarization 
filter  twesked 

USAGE 

RUN  SCNTWK 
INPUT  PARAMETERS 

Rev  #  -  The  revision  number  of  RTGAIU  by  which  the  tsF-e  was 

recorded  ( sn  integer  ) 

TWEAK  -  The  tweak  factor  for  the  polarization  filter*  the 
larger  the  value*  the  more  enhanced  the  filter 
YEAR  -  A  two  disit  number 

FROMIN  -  Minimum  average  correlation  coefficient  for  F  array 
blocks  of  interest 

TROMIN  -  Minimum  average  correlation  coefficient  for  T  array 
blocks  of  interest 

F*T*B  -  Selects  F  array*  T  array*  of  Both  arrays 

3  or  4  -  Selects  the  number  of  channels  in  the  F  array 

START  -  Integer  value  of  first  block  to  be  calculated 

STOP  -  Integer  value  of  last  block  to  be  calculated 

REMARKS 

To  have  valid  results  for  the  first  four  F  array  blocks*  the 
value  of  START  must  be  at  least  four  larger  than  the  block  number 
of  the  tape's  current  position.  It  takes  about  60  seconds  per 
block  to  do  the  calculations, 

LIBRARIES  REQUIRED 

REDL I B , MACL I B , S Y : FORL I B 

METHOD 

The  program  is  a  streamlined  version  of  READ.  Time  series 
analysis  is  only  performed  after  polarization  filtering*  and 
the  analysis  data  is  printed  only  if  the  average  correlation 
coefficient  is  larger  than  the  specified  minimum. 

COMMON  /MTBLK/  IDNSTY  *  IF’ ARTY  » I  STATUS  12) 

COMMON  / 1 ARRAY /  IKPINH  2168  ) » IBKRBY t ICHNLC 7 > 

COMMON  /PASBLK/  I WKHDFK  20 ) , 1 4CHNL< 51 2 *4  ) *  1 3CHNL < 51 2 » 3  ) 

COMMON  /APARAM/  FXHIF<  6  >*FYIUF(  6  >»FTD1F<  6  )*FSIGMA<  4  >.TXDJF<  3  >* 

{ TYDIF( 3  )»TTD1F( 3  ) * TSI GMAt 3  ) 

COMMON  /ANALYS/  IFSPQX*  FRHGVG .  FVELOC *  FAZ  IMF  *  FVF.VAR .  F AZt'AR *  I FSTAT  * 
(FMU<  4  )*FPS1(  4  ) .  FRH0(  6  )*  IFMAX<  4  )*  IFMINC  4  ) *  ITSF'QX, TRHOVG .  TL'ELOC  * 

(TA21KF  .TVEVAR.TA2UAR.  ITSTAT*TMU<  3  >*TFSI<  3  >.TRH0<  3  )*ITMAX(  3  )* 

C ITMIN<  3  ) 

COMMON  /MISC/  ITMPRYC  1536  )  *  I FCNBR *  I  ST AT  *  I TAI LR<  100  >r  ITRGRYf  12? )* 

<  CALLER  * INRDIF  » INRCHL  .ITRMAX.FI MGRY (  256*4  ) 

DIMENSION  IDMTBL(  12  > 

DATA  IDMTBL/4»5»6*2* 3.6* 1*3.5* 1.2.4/ 

DATA  FXDIF/2406. *-5459. . -3685 .♦ -7864 . .-6091 . . 1773./ 

DATA  FYPIF/-5658. .-3099, .1057, .2559. .6715. .4156 . / 

DATA  TXDIF/7 .6.-945 , 3 . -953 ,4/»TYDIF/-1125.9,-578.5*547.4/ 


» 


oooo  o  n  o  o  o  o  o  o  noonno 


DAT-A  INBUFF/"  177562/  ,  IN ASK/"  177/  *  1ABCSF:/’*  177000/ 

DATA  IGETBT/-1/ , I INTDT/0/ » FOUR/ 1HF/ , THREE/ 1 HT/ , BOTH/ 1HB/ 
DATA  XN0/1HN/, YES/1HY/, IN0/-1/ ,  I  YES/ 1  / ,  F'lOVRN/  .  01 227  1 9/ 
DATA  IUNIT/00/  , IBNSTY/800/  *  IF'ARTY/  1  /  , IREV/-J  / 


Prosraiii  and  Bias  tape  initialization  area* 

100  TYPE  10 

102  CALL  HTINIK  IUNIT ) 

IF  <  ISTATIK  1  )  .NE.  IYES  )  STOP 

TYPE  16 

ACCEPT  14, IREVNR 

IF  < IREVNR  .LE.  9)  INRBYT  =  40SO 

IF  (IREVNR  .  GE  *  10)  INRBYT  =  4336 

TYPE  142 

ACCEPT  14 » ITWEAK 

IF  < ITWEAK  .LE.  0)  ITWEAK  =  1 

TYPE  193 
ACCEPT  14.JYEAR 

TYPE  143 

ACCEPT  144,FR0NIN,TR0NIN 

RINDX  -  0. 

DO  119,1  =  1,129 

THETAN  =  C03< PIOVRN*RINDX ) 

ITRGRY(.I  )  =  IFIX(  32767. CTHETAN  +  .5) 

119  RINDX  =  RINDX  +  1. 

103  TYPE  13 

ACCEPT  12,  ARRNBF: 

IF  <  ARRNBF:  .NE.  THREE)  GO  TO  107 
GO  TO  110 

107  TYPE  15 

ACCEPT  14 , IFCNBR 

IF  (IFCNBR  .EG.  4)  GO  TO  110 

TYPE  18 

ACCEPT  14, IMSCHL 

K  =  IMSCHL*3  +  1 

DO  101,1  =  1,3 

FXDIF< I  )  =  FXDIF( IDMTBL<  K  ) ) 

FYDIF< I  )  =  FYDIF< IDMTBL<  K  ) ) 

101  K  =  K  +  1 

110  DO  112, K  =  1,1536 

112  ITHPRY(K)  =  0 

TYPE  190 

ACCEPT  19, 1  START , I ST OP 
KST ART  =  ISTART  -  4 


Tape  read  ares 


oooo  oooo 


109 


CALL  REDTAP<  IUNIT * IHP1NG, INRRYT, ISTATU  ) 

IF  (ISTATU(l)  .EQ.  IYES)  GO  TO  105 
CALL  MTSTAT< IUNIT  ) 

IF  (1ST  ATU<  S  )  .EQ.  IYES)  PAUSE  '  Continuer  <CR . 
GO  TO  109 

IF  (IMPING*  2)  .GE.  KST ART  )  GO  TO  120 
IFUH  =  KST  ART  -  IMPING*  2) 

I FUIi  =  IFWIi  -  1 

IF  (  I  FUIi  .EQ.  0)  GO  TO  109 

CALL  SPCTAP  <  IUNIT,  IFUIi,  ISTATU  ) 

IF  <  ISTATIKl)  .EQ.  INO)  STOP 
GO  TO  109 

IF  (IMPING*  2)  .LE.  ISTOP)  GO  TO  104 

PAUSE  '  **#IiONE**r 
GO  TO  110 

CALL  REtiTAP*  IUNIT » 1UKHHR , INRBYT , ISTATU ) 

IF  (  1ST ATLK  1  )  .EQ.  IYES)  GO  TO  111 
CALL  MTSTAT* IUNIT  ) 

IF  (ISTATU*  8)  .EQ.  IYES)  PAUSE  '  Continue?  <CF:; 
GO  TO  104 

IF  <IUKHHR(2)  .  NE .  IMPING<2)>  GO  TO  114 
IF  <  IWKHPR*  -4  )  .  NE .  IMPING(4))  GO  TO  114 
TYPE  17,INPING(2) 

HO  117,1  =  1,2168 
IMPING*  1  )  =  IUKHHR*  I  ) 

GO  TO  104 

CALL  SPCTAP (  IUNIT , IRE V, ISTATU  ) 

IF  (ISTATU(l)  . EQ .  INO)  STOP 

4444444444444*64446464444644444  66666446446  4  4  4  *4  44* 


lisle  unwind  sree 


CALL  UN  W  IHlt  <  I  HP  I NG  ,  I WKH  I<R ,  I T  MPR  Y  ) 

IF  < IMP ING< 2  )  .LT.  ISTART >  GO  TO  109 
IF  < IREVNR  .GE.  10)  GO  TO  600 
TYPE  141 
STOP 


T  srrey  enelysis  eres 

600  IF  ( ARRNBR  .EQ.  FOUR)  GO  TO  603 

ITSPQX  =  0 

>  CALLER  =  THREE 

CALL  RTGTDS 
C 

IMPING*  18)  =  ITUEAK 

601  CALLER  =  THREE 
CALL  FILTER 

•  604  IF  (ITSPQX  .GT.  0)  GO  TO  606 

TYPE  192, CALLER 
GO  TO  605 
C 


> 


606  CALLER  =  THREE 
FRHOVG  =  TR0H1N 
IMPING(  IS)  =  J YEAR- 
CALL  RTGTDS 
C 

605  IF  (ARRNBR  .EG.  THREE)  GO  TO  10? 

C . 

C 

C  F  array  analysis  area 

C 

IFSPQX  =  0 
CALLER  =  FOUR 
CALL  RTGTDS 
C 

603  CALLER  =  FOUR 

IMPING( 18  )  =  ITWEAK 
CALL  FILTER 

608  IF  (IFSPQX  *GT.  0)  GO  TO  602 
TYPE  192*  CALLER- 
GO  TO  109 
C 

602  CALLER  =  FOUR 

TRHOVG  =  FROMIN 
INFING<  18)  =  J YEAR 
CALL  RTGTDS 
GO  TO  10? 

C . . . . . 

C 

C  FORMATS  area 

C 

10  FORMAT  </.'  SCNTWK  Rev  1.') 

11  FORMAT  < '  ??!  ! '  ) 

12  FORMAT  (Al) 

13  FORMAT  (  '  F,T  or  B?  '  ,$  ) 

14  FORMAT  (312) 

141  FORMAT  ('  THIS  PROGRAM  WILL  NOT  READ  REVISIONS  LESS  THAN  10'  ) 

142  FORMAT  ('  PURFIL  TweaK  factor?  ' .$  ) 

143  FORMAT  ('  Minin.ua  F  RHO.  T  RHO?  '  .$  ) 

144  FORMAT  (2F6.3) 

15  FORMAT  ( '  3  or  4?  '  ,$ ) 

16  FORMAT  ( '  REV  *?  '  .$ ) 

17  FORMAT  ('  BAD  BlocK ,  #',I5) 

18  FORMAT  ('  Missing  channel?  (0*1*2*3)  '.$) 

19  FORMAT  (216) 

190  FORMAT  <'  Start. Stop;  '»$) 

191  FORMAT  (/) 

192  FORMAT  ('  '  . Al » 3X . ' #**INVAL ID  F3 LTER !! ***'  ) 

193  FOFlMAT  ('  Year?  '  ,$  ) 

194  FORMAT  ('  T imeJ ' . 13  * ' , A3* ' , 12 . 1 4  * ' l ' , 12 . '  ',I2.'MZ??  '.*> 

195  FORMAT  ('  Correct  time?  (Y»M»D»H»M)  ') 

196  FORMAT  (713) 

197  FORMAT  (/.'  *'.5I6) 

198  FORMAT  ('  @  WBA'  *  13 » ' ,  A3* '  ,  12 . 14 . '  *. '  » 12.  '  '  .  1 2 . '  "  Z  .  '  ) 

C . . . . . 

C 

500  STOP 

END 
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C************  STATS  .FOR  **********!*:**A)»:*##**!«:)t***4:4;)t<:***J|:3e:*)»:*4:*a:**)t*^ 

Date  of  revision;  29-Aug-82 
PROGRAM  STATS 
PURPOSE 

To  seen  one  or  more  teres  end  determine  average  values 
of  statistics 

USAGE 

RUN  SCAN 

INPUT  PARAMETERS 

YEAR  -  A  two  disit  integer 

F*T*B  -  Selects  F  array*  T  array*  or  Both  arrays 
RHOMIN  -  Minimum  averese  correlation  coefficient  for  blocks  of 
interest 

DIFNIN  -  Minimum  change  in  average  correlation  coefficient  after 
polarization  filtering 

UELNIN  -  Minimum  value  of  velocity  for  blocks  of  interest 

VELNAX  -  Maximum  value  of  velocity  for  blocks  of  interest 

STATS  -  If  Y  is  entered*  stetistics  will  be  printed  for  eech 
block  of  interest 

START  -  Integer  value  of  first  block  to  be  scanned 

STOP  -  Integer  value  of  last  block  to  be  scanned 

REMARKS 

When  an  TErrO  is  encountered*  that  block  is  skipped  and  should 
be  read  by  program  F:EAD  to  recover  lost  data 

LIBRARIES  REQUIRED 

redlib*naclib»sy:forlib 

METHOD 

The  program  scans  the  trailer  data  of  the  tape  starting  at  START, 
If  the  value  of  RHQ  is  greeter  than  RHOMIN  or  the  change  in  RHO 
is  greater  than  BIFNIN*  then  the  statistics  are  summed  (and 
printed  if  reouested).  When  an  EOF  (  end-of -f  i  le  )  or  the  STOP 
block  is  encountered*  the  program  then  allows  for  another  scan. 

DIMENSION  INPONG(IOO) 

COMMON  /KTBLK/  IDNSTY  * IPARTY  *  1ST  ATU< 12  ) 

DIMENSION  I WKSF'C<  2168) 

COMMON  /TRAILY/  IMP2NG<  2068  >  *  FVELOC  *  FAZ I MF ,  FVEt'AR .  FAZt'AR » IFST  AT  , 

CFMLK  4 ) *FPSI( 4  )  *FRH0(  6  )  *  IFMAXv  4  )*IFMIN(4  )*  IFSPOX.*  FRHOVX  *  FUEL  OX  * 

C  FAZINX  tFVEVAX  *  FAZVAX  *  TVELOC*  T  AZI MF  *  Tt'EVAR  *  T  AZV  AR  *  I TSTAT  *  TMLH  3  >  r 
CTPSI<  3  >»TRH0<  3  ),1TMAX(  3  >*  ITNIN<  3  >*  ITSPOX,TRHDVX»TVEL.OX*TAZ  JMX  , 
t.  TVEVAXtTAZUAX 

DIMENSION  TNAXT(  3 )* TMINT(  3  >*TMUT(  3  >*TPSIT< 3 )*TSIGMT(  3 ) 

DIMENSION  FNAXT<  4  >*FH3NT<4  >*FMUT( 4  >,FPSIT<  4 )*FSIGMT(  4 ) 

DIMENSION  IHEADR<  20  ),  IHEAD2(  20  )*  IHEADK  20  ) 

DIMENSION  FSIGMA<  4  )*TSIGMA<  3  ) 

DATA  I ZERO/O/  *  FOUR/ 1 HF/  »  THREE/ J.HT/  *  BOTH/1  HB/ 

DATA  XH0/1HN/ *  YES/1 HY/*I NO /-1/*I YES/1/ 

DATA  1UNIT/00/ . IDNSTY/800/ *  1 PARTY/ 1 / *  I REV/- 1 / 


Program  and  mag  tape  initialization  area. 
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TYPE  10 
TYPE  193 
ACCEPT  19  *.JYEAR 

CALL  MTINIT< I  UNIT ) 

IF  <  ISTATli<  1  )  ,  NE .  IYES  )  STOP 

IGFLAG  =  I MO 
TYPE  13 

ACCEPT  12.ARRNBR 
TYPE  18 

ACCEPT  14.RH0KIN 
TYPE  171 

ACCEPT  14  *  D1FNI N 
TYPE  174 

ACCEPT  14  *  VELM1N 
TYPE  175 

ACCEPT  14 » VELMAX 

IF  (VELMAX  .EG.  0.)  VELMAX=1 0000 . 
TYPE  16 

ACCEPT  12. STATS 

KUONT =0 
K0UNT=0 
DO  110  1=1*4 
FMAXT ( I )=0 . 

FHINTt  I  )=0 . 

FNUT< I  )=0. 

FPSIT< I  )=0 . 

FSIGMTt I )=0. 

IF  <1  ,EQ .  4)  GO  TO  110 
TNAXT<  I  )=0 . 

TNINT<I)=0. 

THUT<  I  )=0. 

TPSIT< I )=0. 

TSIGMTC I )=0, 

110  CONTINUE 


T see  read  ares 

200  TYPE  190 

ACCEPT  19 » I START  *  I ST OP 
IF  (ISTART  .EQ,  0)  ISTART  =  1 
IF  (ISTOP  .EQ.  0)  ISTOP  =  10000 
I STOP  =  ISTOP  +  2 
C 

DO  243*1  =  2069*2168 
243  INPING(  I  >=0 

C 

209  DO  245.1  =  1.100 

II  =  I  +  2068 

245  INPONG<  I  )=IMPING<  1 1  ) 

C 

IF  < IGFLAG  .EQ.  IYES)  GO  TO  201 

CALL  REDTAP< IUNIT . IMPINC. INRBYT . ISTATU  ) 

IF  < 1ST ATU( 1  )  .EQ.  IYES)  GO  TO  205 


» 


o  n  n  o 


CALL  HTSTAT< IUNIT  ) 

IF  (1ST ATIK  8  )  .EG.  IYES  )  GO  TO  208 
GO  TO  209 


C 

205 


C 

220 

C 

208 


C 

204 


C 

211 

C 

201 

217 


C 

214 


IF  < I  HP  I NG<  2  )  .EG.  ISTART)  GO  TO  220 
IFUIi  =  ISTART  -  IKF’ ING(  2  ) 

IF UK  =  IFWH  -  1 

IF  ( IFWD  .EG.  0)  GO  TO  209 

CALL  SPCTAP  < IUNIT»IFWIUISTATU) 

IF  (1ST ATIK  1  )  .EG.  IKO  )  STOP 
GO  TO  209 

IF  (IHPING<2)  .LE.  ISTOP)  GO  TO  204 

PAUSE  '  #**HONE***' 

TYPE  15 

ACCEPT  12 » CONTNU 

IF  (CONTNU  .NE.  YES)  GO  TO  700 

IF  (  1ST ATU<  8  )  .ECU  IYES  )  CALL  RENT AP(  IUNIT , 1ST ATU  ) 
GO  TO  200 

CALL  REDT  AF'(  I  UNIT  »IUKSF‘C,  INRRYT  ,  ISTATU  ) 

IF  (ISTATU(l)  .EG.  IYES)  GO  TO  211 
CALL  MTST AT(  IUNIT ) 

IF  (1ST  ATU(  8  )  .EG.  IYES)  GO  TO  208 
GO  TO  204 

IF  (  IWK.SF’C(  2  )  .NE.  IMPINGC2))  GO  TO  214 
IF  ( IWKSPC( 4  )  .NE.  IHPI NG(  4  )  )  GO  TO  214 

DO  217,1  =  1,2168 
INPING(  I  )  =  IUKSF'C(  I  ) 

IGFLAG  =  I NO 
GO  TO  204 

IGFLAG  —  IYES 

IF  ( INPING(  2 )  .GT.  ISTOP)  GO  TO  208 


Tape  block  setup  and  ?ErrO  detection  area 

300  DO  301,1  =  1,20 
IHEADR(  I  )  =  IHEAD2(  I  ) 

IHEAU2(  I  )  =  IHEADK  I  ) 

301  IHEADK  I  )  =  IHPINGC  I  ) 


ITRFLG  = 
IFRFLG  = 


DO 

343,1  =  2158,2168 

II 

=  I  -  2068 

343 

IF 

(IKPING(I)  .EO.  IHPONG(II)) 

ITRFLG  = 

ITRFLG 

+ 

1 

IF 

( ITRFLG  .EG .  11 )  GO  TO  347 

DO 

345,1  =  2114*2124 

II 

=  I  -  2068 

345 

IF 

(IHPlNC(l)  .EG.  INPONG(II)) 

IFRFLG  = 

IFRFLG 

1 

GO 

TO  349 

347 

DO 

348,1  =  2069,2124 

II 

=  I  -  2068 

348 

IF 

(IHPINC(I)  .EG.  IHF'ONG(II)) 

ITRFLG  = 

ITRFLG 

+ 

1 

IF 

(ITRFLG  .LT.  67)  GO  TO  349 

i 


! 


n  n  o  n 


GO  TO  209 


C 

349  FRHOVG  =  0. 

DO  302.1  =  1,6 

302  FRHOVG  =  FRHOVG  +  FRHO< I  ) 

FRHOVG  =  FRHOVG/6. 

C 

HO  304.1  =  1.4 

FSIGNA<  I  )  =  FF’SK  I  )**2  -  FKIK  I  )*42 
IF  <FSIGMA<I)  .LT .  0.)  FSIGMAt  I  )  =  0. 
304  FSIGNA< I  )  =  SORT ( FS I GNA< I  )  ) 

C 

TRHOVG  =  0. 

HO  303.1  =1.3 

TSIGMA<  I  )  =  TPSI<I>**2  -  TMU< I >**2 
IF  (TSIGNA'.I)  . LT ♦  0.)  TSIGNAC I  )  =  0. 
TSIGHA'.I)  =  SQRT(  TSIGHAC  I  )  ) 

C 

303  TRHOVG  =  TRHOVG  +  TRHO'. I  ) 

TRHOVG  =  TRHOVG/3 . 

TROHIF  =  TRHOVX  -  TRHOVG 
FROHIF  =  FRHOVX  -  FRHOVG 

C 

IF  (  IHEAOR(  2  )  ,GE.  ISTART  )  GO  TO  600 
GO  TO  209 


T  array  signal  detection  ares 


600 


» 


C 

623 


I 


C 


*  c 


609 

*  601 

606 

663 


IF 

( TRHOVG 

.GE. 

RHDNIN) 

GO 

TO 

623 

IF 

( TRHOVX 

.GE. 

RHOMIN ) 

GO 

TO 

623 

IF 

( FRHOVG 

.GE. 

RHONIN  ) 

GO 

TO 

623 

IF 

<  FRHOVX 

.GE. 

RHOttIN) 

GO 

TO 

623 

IF 

<  TRODIF 

.GE. 

niFNIN  ) 

GO 

TO 

623 

IF 

<  FROHIF 

.GE. 

DIFNIN) 

GO 

TO 

623 

GO  TO  209 

I IBKNR  =  IHEAI<R(  2  ) 

JHAY  =  IKEAHR( 3  ) 

JHOUR  =  IHEAHR( 4  ) 

JSEC  =  IHEAOR< 5  ) 

IERRTO  =  IHEAOR( 17  ) 

I2ER0N  =  IHEAOR< 18 ) 

IOVRNG  =  IHEAHR(19) 

IUNURN  =  IHEAOR<  20 ) 

JFLAG  =  I2ER0 

CALL  RTCLOK.  ( JFLAG. ANONTH. JDAY, JHOUR, JHIN, JSEC  ) 

IPFLAG  =  INO 
IEFLAG  =  INO 

IF  ( ARRNBR  .EQ.  FOUR)  GO  TO  605 

IF  <  <  TRHOVG  .GE.  RHONIN ) . OR . ( TROKIF . GE . HIFKIN  ) )  GO  TO  609 
IF  <  TRHOVX  .LT.  RHONIN >  GO  TO  605 
GO  TO  604 

IF  (ITSTAT  -  0)  601.663.606 
TYPE  180. THREE 
GO  TO  604 

IF  < TRHOVG. GE.RHONIN)  GO  TO  604 
IF  <  TROHIF .LT.OIFMIN)  GO  TO  604 


I 


o  o  o  o 


»  C 

604 


611 

C 

610 

*  612 
C 

613 

C 

►  614 


630 

C 

605 


IF  <  TVELOX  ,LT .  VELMIN )  GO  TO  605 
IF  (  TVELOX  .GT.  VELMAX  )  GO  TO  605 

IF  (STATS  .HE.  YES)  GO  TO  610 

TYPE  197. IIBKNR. IERRTO, IZERON, IOVRNG . IUNDRN 

IEFLAG  =  I YES 

TYPE  198, JDAY.AHONTH.J YEAR, JHOUR.JMIN.JSEC 
IPFLAG  =  I YES 
TYPE  187, THREE. TRHO 
HO  611,1  =  1,3 

TYPE  185.  THREE ,  ITMAX(  I  >,  ITHIN<  I  >,TNU(  I  ),TPSI<  I  ),TSIGKA(  1  ) 

IF  (  (  TRHOVX  .LT.  RHOHIN ). ANIU (  TRDKIF . LT . DIF KIN >  )  GO  TO  605 
IF  ( ITSPQX  -  0)  612,613,614 
TYPE  192, THREE 
GO  TO  605 

TYPE  180 
GO  TO  605 

IF  (TVELOX  .LT.  VELMIN )  GO  TO  605 
IF  (TVELOX  .GT.  VELMAX  )  GO  TO  605 
HO  630  1=1,3 

TMAXTC  I  )=TMfiXT(  I  )+FLOAT(  ITMAX(  I  )  ) 

THINK  I  )=TMINT (  I  )+FLOAT(  ITHIN(  I  >  ) 

Ti1UT(  I  )=TMUT(  I  )+TMU(  I  > 

TPSIT(  I  )=TPSIT(  I  )+TPSI<  I  ) 

TSIGHK  I  )=TSIGMT(  I  )+TSIGNA(  I  ) 

CONTINUE 

KOUNT  =  FOUNT  +  1 

IF  <  ARRNKR  .EQ.  THREE)  GO  TO  209 
IF  < 1FRFLG  .EQ.  11)  GO  TO  209 


F  array  signal  detection  area 
603  I  HUM  =  IHEAUR<2>  -  3 

IF  <  (  FRHOVG  .GE.  RHOMIN ) , OR . ( FROKIF . GE . DIFMI N ) )  GO  TO  621 
IF  (FRHOVX  .LT.  RHOMIN)  GO  TO  209 
GO  TO  602 

621  IF  (IFSTAT  -  0)  607,664,608 

607  TYPE  180, FOUR 
GO  TO  602 

608  IF  (FRHOVG. GE, RHOMIN)  GO  TO  602 

664  IF  (FROKIF. LT.PIFNIN  )  GO  TO  602 

IF  (FVELOX  .LT.  VELMIN  )  GO  TO  209 
IF  (FVELOX  .GT.  VELMAX)  GO  TO  209 
C 

602  IF  (STATS  ,NE.  YES)  GO  TO  615 

IF  (IEFLAG  .EQ.  1YES  )  GO  TO  632 
TYPE  197 , IIBKNR, IERRTO, IZERON, IOVRNG, IUNDRN 
TYPE  198, JKAY , ANONTH, JYEAR , JH0UR,3MIN, JSEC 
IEFLAG  =  I YES 
632  TYPE  181, FOUR, FRHO 

PO  616,1  =  1,4 

616  TYPE  185, FOUR, IFMAX(  1 ), IFMIN( I  )»FMU( I  )»FPSI( I  )»FSIGMA( I  ) 

C 

615  IF  ((FRHOVX  .LT.  RHOMIN ). AND .( FROKIF . LT . PIFMIN  )  )  GO  TO  209 
IF  ( IFSPQX  -  0)  617,618,619 


» 


n  o  n  o 


617  TYPE  192. FOUR 
GO  TO  209 

C 

618  TYPE  180. FOUR 
GO  TO  209 

C 

619  IF  (  FVELOX  ♦ LT ♦  VELMIN  )  GO  TO  209 
IF  ( FVELOX  .GT*  VELMAX  )  GO  TO  209 
DO  645  1=1.4 

FMAXT<  I  )=FNAXT (  I  HFLOATC  IFMAX(  I  >  ) 

FMINTC  I  )=FNINT<  I  >+FLGAT<  IFNIW  I  )  ) 

FNUT< I  )=FMUT ( I )+FMU( I  ) 

FPSIT(  I  )=FF’SIT(  I  )+FPSI(  I  ) 

FSIGMT( I  )=FSIGMT( I )+FSIGMA<  I  ) 

645  CONTINUE 

KUONT  =  KUONT  +  1 
GO  TO  209 
C 

700  IF  (ARRNBR  .EQ.  FOUR)  GO  TO  702 
TYPE  188. THREE. KOUNT 

COUN . =FLOAT ( KOUNT  ) 

DO  701  1=1,3 
TMAXT < I  )=TMAXT( I  )/COUNT 
TMINT (  I  )=TMINT<  I  )/COUNT 
TMUT ( I  )=TMUT< I  )/COUNT 
TPSIT(  I  )=TPSIT(  I  i/COUNT 
TSI GNT ( I  )=TSIGMT(  I >/COUNT 
KTMAX=IFIX( TMAXT ( I )  ) 

KTMIN=IFIX(  TMINTi  I ) ) 

TYPE  185, THREE, KTMAX, KTMIM, TMUTC  I >,TPSIT< I  ),TSIGMT<  I  > 

701  CONTINUE 

702  IF  (ARRNBR  ,EQ,  THREE)  GO  TO  5 00 
TYPE  188, FOUR, KUONT 
CUONT=FLOAT( KUONT  ) 

DO  703  1=1,4 
FMAXT (  I  )=FMAXT(  I  VCUONT 
FMINTC  I  )=FNINT(  I  )/CUONT 
FMUT ( I >=FMUT< I  )/CUONT 
FPSIT<  I  )=FF'SIT(  I  )/CUONT 
FSIGMT( I  )=FSIGMT( I  )/CUONT 
KFHAX=IFIX( FMAXT (  I ) ) 

KFMIN=IFIX<  FMINT< I )  ) 

TYPE  P.5,  F  OUR,  KFMAX ,  KFMIN,  F  HUT (  I  ),FPSIT(  I  ),FSIGMT(I  ) 

703  CONTINUE 


FORMATS  are® 


10 

FORMAT 

</,'  STATS  Rev  1.'  ) 

12 

FORMAT 

<  A1  ) 

13 

FORMAT 

<  '  F»T  or  B?  ' ,$  ) 

14 

FORMAT 

<  F6  »  2  ) 

15 

FORMAT 

( '  Continue?  ' »♦  ) 

16 

FORMAT 

( '  Statistics?  ' ,$  ) 

17 

FORMAT 

('  BAD  BlocK ,  #'  ,15) 

171 

FORMAT 

( '  Minimum  CHANGE  IN 

RHO?  '  ,$  ) 

172 

FORMAT 

<55X»'?ErrO  at  BlocK 

*'  ,15) 

173 

FORMAT 

(40X,'?Err0  at  BlocK 

*'  ,15) 

174 

FORMAT 

< '  VELMIN?  '  t% ) 

175 

FORMAT 

< '  VELMAX?  '  ,$ ) 

u  o 


18 

FORMAT 

( '  Minimum  RHO?  ' » $  ) 

180 

FORMAT 

('  '  .Alf3X»  '***  INVALID  ANALYSIS!!**:*:') 

181 

FORMAT 

('  '  tAl »3X,6F5.2  ) 

182 

FORMAT 

<'  F' 1 16 1 '  to' tI5t3X*I4t2F6.1t3X»'<' tF4.2.'  >'f2FB.?f 

& 

16X»F5. 

2  ) 

183 

FORMAT 

('  T' »16»11X*I4»2F6.1»19X»'< ' » F4  « 2» '  >' » 2F8 . 7% F5, 2 ) 

184 

FORMAT 

<'  ' tAl t 2Xt6F5.lt F5. 2) 

185 

FORMAT 

<'  ' .A1 »2I6»3F7. 1 ) 

186 

FORMAT 

<'  ' »Alt2Xt3F6.2« 12XtF5.2) 

187 

FORMAT 

('  ' tAl t 2Xt 3F5.2  ) 

188 

FORMAT 

< ' OAUERAGE  VALUES  OF  ',A1»'  ARRAY  STATISTICS  FOR  ', 

& 

16 »'  BLOCKS'  ) 

1? 

FORMAT 

<  216  ) 

190 

FORMAT 

<'  Stsr  1 1  Stop  t  '.$) 

191 

FORMAT 

</  ) 

192 

FORMAT 

('  '  .A1.3X.'  ***INVALIH  FILTER!!**:*:') 

193 

FORMAT 

<  '  Yesr-T  '  t $  ) 

194 

FORMAT 

('  Timet' »A3t'-',I2»I4t' i' »I2t'  '»I2t'"Z??  '»*) 

196 

FORMAT 

<713  ) 

197 

FORMAT 

</»'  #' » 516 ) 

198 

FORMAT 

('  g'  »I3t'-'  »A3»'-'  tI2tI4t' t'  »I2»'  '  1 1 2 1 '  Z . '  ) 

500 

STOP 

END 

1  Rra*LIt'RARlflN  V03'0'  Wl  4|:9D&:|?  88*88*88 


MODULE  GLOBALS  GLOBALS  GLOBALS 

MTINIT 

MTSTAT 

RTGTDR 

FILTER 

BEMEST 


_ ^  PIIDCTI 
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C#*#*#***#***#  PURE XL .FOR 

Date  of  this  revision  t  25-May-82  rAn  vrriv>n  .sri  ntAV 

P  =  C N#Tr<  S**2  )  -  Tr<  S  )**2D/C(  N  -  1  )*Tr<  S  )**2 1  where  eec-h  Trace 
and  cross-term  series  is  appropriately  condi ti oned .  i,e.  has  a 
"running  averager"  (SMOOTH)  applied  three  times.  n.b.  This  revi 
sion  has  exponentiation  ("tweaking")  applied  to  the  filter  coef¬ 
ficients  through  the  factor  ITWEAK  (passed  as  IMPING(  18  ) ). 

SUBROUTINE  PURF IL( FREARY  ) 

COMMON/array  area 

COMMON  /1ARRAY/  IMPING( 2168  ) . IBKRUY , ICHNL( 7  ) 

COMMON  /MISC/  ITMPRY( 1534  ) . IFCNBR . ISTAT . ITA ILR<  1 00  )  *  I TRGRY(  1 29  ) , 
( CALLER » 1NRDIF* INRCHL  * ITRMAX.FIMGRYC 254*4  ) 

COMMON  /URKSPC/  DUMMYK  254  ),DUMMY2(  254  )*  TRACEIK  254  ) » TRACFN(  254  ) 
DIMENSION  P0LAR2(  254  )*FREARY(  254*4  ) 

EQUIVALENCE  (  POLARK  1  )*DUMMY1(  1  )  ) 

. . routine  ares . . . . . . . 

Insure  that  DC  terms  are  0! 

10  DO  11. I  =  1. INRCHL 
FREARYC l.I  )  =  0. 

11  F IMGRY ( 1*1  )  =  0. 

IN  =  INRCHL  -  1 
F1C0EF  =  l./FLOATtIN) 

F2C0EF  =  F1C0EF*FL0AT( INRCHL  ) 


Form  trace  terms  of  spectral  matrices  and  determine  position 
( freauency  )  of  last  (if  more  than  one)  maximum  value, 

ITWEAK  =  INPING< 18 ) 

DO  20* I  =  1*254 
TRACED< I  )  =  0. 

20  TRACEN(  I  )  =  0. 

DO  21*1  =  1. INRCHL 
DO  22. J  =  1.254 

22  DUMHYl(O)  =  FREARY(  J  .  I  )*FREARY(  J  *  I  >  +  FIMGRY(  J .  I  )*FJ  MGRY<  J .  I  ) 

DO  23.N  =  1.3 

23  CALL  SM00TH( DUMMY  1  ) 

DO  21 »K  =  1.256 

TRACED(K)  =  TRACEIK  K  )  t  DUMMY  1<  K  ) 

21  TRACEN(N)  =  TRACEN(  K  )  +  DUMMYK  K  )#HUMMY1(  K  ) 

TRACEM  =  0. 

ITRMAX  =  0 
DO  24.1  =  1.256 

IF  (TRACEIK  I)  .LT.  TRACEM)  GO  TO  25 
TRACEM  =  TRACEIK  I  ) 

ITRMAX  =  I 

25  TRACET  =  TRACEIK  I  )*TRACEIK  I  ) 


oono  o  o  no  noon 


IF  (TRACE!  ,GT.  0.)  GO  TO  24 
ITRMAX  =  0 
GO  TO  50 

24  TRACEIU  I  )  =  F2C0EF/TRACET 


For*  cross-terms  of  spectral  metrices, 

HO  30,1  =  1 » IN 
II  =  I  +  1 

DO  30,. J  =  1 1 , INRCHL 

DO  32, K  =  1,256 

DUMMY 1<  K  )  =  FREARY(K,I  )*FREARYC K, J  )  +  FIMGRY<  K,  I  )*FIMGRY<  K,  ..J  ) 

32  DUMMY2(K)  =  FIMGRYv  K,  I  XFREARYC  K,  J  )  -  FREARYC  K ,  I  )*FINGRY<  K , ,?  ) 

DO  33, N  =  1,3 
CALL  SMOOTH*:  DUMMY  1  ) 

33  CALL  SMOOTH<  DUNMY2  ) 

DO  30, L  =  1,256 

DUMMY3  =  0UMMY1(L)**2  +  DUMMY2<  L  )*3fe2 
TRACEN(L)  =  TRACEN(L)  +  2.MUMMY3 
30  CONTINUE 


Compute  degree  of  "polsri ration"  end  filter  date. 

POL  AR2<  1  )  =  0. 

DO  40,1  =  2,256 

FOLARZC  I  )  =  TRACEN<  I  XTRACEIK  I  )  -  F1C0EF 
40  P0LARZ<  I  )  =  POLARZC  I  )**1TI4EAK 

DO  41,1  =  1,  INRCHL 

DO  41, J  =  1,256 

FREARY<  J ,  I  )  =  FREARYC  J ,  I  )*F'0LACZ<  J  )  +  .5 
>  41  F  IMGRY<  J ,  I  )  =  FIMGRY(  .J ,  I  )*P0  '  2 <  J  )  +  .5 

C 

50  RETURN 

END 


,  SUBROUTINE  SMOOTH*  VECTOR  > 

C 

DIMENSION  VECTOR'.  256  ) 

C 

TEMPI  =  0. 

TEMP2  =  ,5#VECT0R<1)  +  . 25*VECT0R<  2  ) 

>  TEMP3  =  ,5*VECT0R<  256  )  +  .  25*VECT0R<  255  ) 

DO  99 » I  =  2,255 
11=1-2 

IF  (II  .GT  ♦  0)  VECTOR(Il)  =  TEMPI 
TEMPI  =  TEMP2 

TEMP2  =  VECTOR(I-l)  +  VECTOR'.  I  )  +  VECTGR(  I  >  +  VECT0R(  1  +  1) 

I  79  TEMP2  =  ,25*TENP2 

VECT0R<  254  )  =  TEMPI 
VECT0R<  255 )  *  TEHP2 
VECT0R< 256 )  =  TEMP3 


I 


RETURN 

END 


--  ^ 
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'  £*************  RTGTDS.FOR  tt*Ztt**t**Z*t******ttt*Z**.**t*t.**t*tt**.t***: 
Date  of  revision:  5-Jun-82 

A  subroutine  to  do  the  Time  Domain  Analyses  of  RTGAIU  data. 

This  version  will  only  print  an  output  if  RHQVG  is  greater  than 
the  user  specified  value.  It  is  intended  for  use  with  SCNTWK* 

SUBROUTINE  RTGTBS 

COMMON  /I ARRAY/  I HP INK  2168  > 

COMMON  /PASBLK/  IUKHDRC 20  >, I4CHNLC 512*4 >» I3CHNL< 512.3 ) 

COMMON  /APARAM/  FXBIF<  6  ).FYniF(  6  ),FTBIF(  6  >,FSIGMA(  4  )>TXDIF<  3  >, 
CTYDIF(  3  )»TTBIF(  3  >»TSIGMA(  3  ) 

COMMON  /ANALYS/  IFSPQX , FRHOVG , FUELOC , FA2 IMF , FVEVAR ,  FAZVAR , I FST AT , 
CFMU(4  >,FPSI(  4  ),FF:H0(  6  ),IFMAX<  4  ), IFMINC 4  ), ITSPQX.TRHOVG.TUELOC, 
CTA2IMF »TUEUAR»TAZVAR»  ITSTAT » TMU<  3  ),TPSI<  3  ),TRH0(  3  ),ITMAX(  3  >, 

CITMI « 3 ) 

CO'V.uN  /MISC/  ITMPRY<  1536  )  *  IFCNBR » ISTAT  » ITAI  LR<  100)»ITRGRY<  129  >, 
CCA*. LER.,  INRBIF *  INRCHL  •  ITRMAX » FIMGRY(  256.4  ) 

COMMON  /URKSPC/  IWKSPC<  1152  >»RHOARY(  65  ),  IEND, J END ,  I  BUM  >  Till  F  » 
CRHOMAX.FDIF 

DATA  IYES/ 1/ » INO/- 1/ . THREE/ 1HT/ . FOUR/ 1RF / . YES/ 1HY/ 

• . . . routine  sres.... . . . .  . . . . . 


Compute  cross-correlations  (normalized  cover i ences  )  between 
ell  peirs  of  the  arrays. 

IF  (CALLER  .EG.  THREE)  GO  TO  59 

Here's  the  four  element  <F)  enelysis. 

ISTAT  =  INO 
INRBIF  =  6 

IF  (IFCNBR  .EG.  3)  INRDIF  =  3 
FNRHIF  =  FLOAT < INRBIF  ) 

C 

64  DO  60,1  =  1, IFCNBR 

CALL  NAXMIN< I4CKNL< 1,1 >,IFMAX< I  ),IFMIN< I  )) 

IF  (IFSPQX  .EG.  0)  GO  TO  60 

CALL  MUNPSK  I4CHNL(  1,1  >,FMU(  I  >,FPSI(  I  )  ) 

FSIGMAC  I  )  =  FPSI(I)  -  FMU(  I  )*Z2 
IF  (FSIGMA(I)  ,LE.  0.)  GO  TO  62 
FSIGNAC I  )  =  SQRT( FSIGMA( I  )  ) 

FPSI( I  )  =  SQRT( FPSI( I  )  ) 

60  CONTINUE 

IF  (IFSPQX  .EG.  0)  RETURN 
C 

FRHOVG  =  0. 

IEND  =  IFCNBR  -  1 
JENH  =  IFCNBR 
N  =  1 

DO  61,1  =  1 , IEND 
K  =  I  +  1 

n 

t> 

DO  61, J  =  K.JEMB 

CALL  RTXCOVK  I4CHNL( 1,1 ) , I4CHNLC 1 , J  ) , IUKSPC , RHOARY  ) 

C 

RHOKAX  =  -10000. 


I 


o  n  o  o 


FHIF  =  32. 

Dll  63* L  =  1*65 

IF  <  RHOARY<  L  )  .LE.  RHOMAX)  GO  TO  63 
RHOMAX  =  RHOARYl L  ) 

FTIHF(M)  =  FDIF 
63  FIHF  =  Fill F  -  1. 

FRHO(M)  -  (RHOMAX  -  FMU<  I  )*FMU<  J  ) )/(  FSIGMA(  I  )*FSIGHA<  J  )  ) 

FRHOOG  =  FRHOVG  +  FRHO<  M ) 

61  M  =  M  +  1 

FRHOVG  =  FRHOVG/FNRIi  IF 

JYEAR  =  IMF’ ING<  18  ) 

CALL  BEHEST 

62  IFSTAT  =  ISTAT 

67  I HUM  =  I WMHDR<  2 )  -  3 

IF  < IFSTAT  -  0  )  66*69*68 

66  TYPE  10.CALLER 

GO  TO  69 

68  IF  <  FRHOVG  .LT.  TRHOVG  )  RETURN 

JDAY  =  I HP I NG<  3  ) 

JHOUR  =  INPIMG<4) 

•JSEC  =  IMF’ING<  5  ) 

JFLAG  =  0 

CALL  RTCLOKX JFLAG , AMONTH, JDAY .JHOUR* JHIN, JSEC  ) 

TYPE  18 . JUAY , AHOHTH *  JYEAR . JHOUR , JttI N .JSEC 

TYPE  12*IIlUM,IUKHDR(2  ) ,  IFSPGX  ,  FAZUAR .  Fl'EVAR,  FRHOVG , FAZI MF , FVEL  DC 

69  RETURN 


Here's  the  three  element  <T)  analysis. 


59  ISTAT  =  INO 

DO  50*1  =  1.3 

CALL  HAXHIN< I3CHNLC 1.1 ).ITHAX< I >,ITMIN(  I  )> 

IF  < ITSPQX  .EG.  0)  GO  TO  50 

CALL  HUMPSK  I3CHNLI 1,1  ),THU<  I  )*TPSI(  I  )  ) 

TSIGHA(I)  =  TPSI(I)  -  THU(  I  )**2 
IF  ( TSIGHAl I  )  .LE.  0.)  GO  TO  52 
TSIGMAl  I  )  =  SQRT<  TSIGMA< I  )  ) 

TPSIC  I  >  =  SGRT(  TF'SK  I  )  ) 

50  CONTINUE 

IF  (ITSPQX  .EG.  0)  RETURN 

TRHOUG  =  0. 

H  =  1 

DO  51,1  =  1,2 
K  =  I  +  1 

DO  51, J  =  K*3 

CALL  RTXCOV<  I3CHNLC  1,1  ),I3CHNL<  1  *  J  )  *  I  WK.SPC*  RHOARY  > 

RHOHAX  =  -10000. 

TDIF  =  8. 

DO  53, L  -  1,65 

IF  (RHOARY(L)  .LE.  RHOMAX)  GO  TO  53 
RHOHAX  =  RHOARY(L) 

TTDIF(H)  =  TDIF 
53  TDIF  =  TDIF  -  .25 


c 


f 


t 


r 


♦ 


t 


* 


» 


51 


C 


C 


52 


56 

54 


57 
C  »  *  * 

c 

10 

11 

12 

13 

14 

15 

16 

17 

18 
C 


TRH0<  M  )  =  <  RHOMAX  -  TMlK  I  )*TMU<  J  ) )/(  TSIGMA<  I  )*TSIGMA<  J  ) ) 
TRHOVG  =  TRHOVG  +  TRHO<  M  ) 

M  =  M  +  1 

TRHOVG  =  TRHOVG/3. 

INRDIF  =  3 
CALLER  =  THREE 
JYEAR  =  IMPINGC 18 ) 

CALL  BEHEST 
ITSTAT  =  ISTAT 

IF  ( ITSTAT  -  0  )  56*  57  *5+ 

TYPE  10* CALLER 
GO  TO  57 

IF  (TRHOVG  .LT.  FRHOVG  )  RETURN 
JHAY  =  1NPING<  3  ) 

JHOUR  =  IHPING<  4  ) 

JSEC  =  INPING' 5  > 

JFLAG  =  0 

CALL  RTCLOK<  JFLAG* ANONTH* JHAY , JHOUR* JMIN. JSEC  ) 

TYPE  18 » JDAY  *  ANONTH ,  JYE AR ♦ JHOUR*  JMI N  *  JSEC 

TYPE  13* I WKHDR< 2  > , I TSPGX, TA2 VAR, T VEVAR * TRHOVG , TAZI MF , TVELOC 
CONTINUE 


FORMAT  (  ' 
FORMAT  (' 
FORMAT  (' 
FORMAT  (' 
FORMAT  < ' 
FORMAT  (' 
FORMAT  (' 
FORMAT  < ' 
FORMAT  < ' 


'  ,A1*3X, '  ***INVALIIt  ANALYSIS  !  !  ) 

'  * A1 , 3X, 6F5  *  2  ) 

F' ,16*'  to'  * I5»3X* 14 ,2F6» 1 *3X* ' ( '  ,F4.2*'  >' *2F8.2) 
T' ,I6*11X,I4*2F6»1*19X,'< ' *F4  *  2* '  )' *2F8.2  ) 

' *A1*2X,6F5.1*F5.2> 

'  *Al ,  216 » 3F7 . 1  ) 

' » A1 »  2X*  3F6 «  2  * 12X  *  F5 . 2  ) 

'  , A1 , 2X»  3F5 . 2  ) 

*13*'-' *A3*'-' *12*14*'  J'  ,12,  '  '  ,12,' "l,'  ) 


RETURN 

END 


I 


> 


I 


ono  onooo  o  o  n  n  n  on  no 


t 


C#*#*****##*#*  RTGTDX .  FOR 

Date  of  revision!  6-Sep-82 

A  subroutine  to  do  the  Tide  Domain  Analyses  of  RTGAIW  data. 

This  version  will  only  print  an  output  if  RHOVG  is  greeter  than 
the  user  specified  value.  It  is  intended  for  use  with  SCNTK2. 

SUBROUTINE  RTGTDX 

COMMON  /I ARRAY/  IMPING(  2168  > 

COMMON  /PASBLK/  IUKHBR(  20 ) , I4CHNL(  512 , 4 > . I3CHNL(  512 . 3 > 

COMMON  /AF'AFtAN/  FXHIF(6  )»FYDIF(  6  >,FTDIF(  6  ),FSIGMA(  4  ).TXDIF<  3  ), 
i  TYDIF(  3  ),TTDIF(  3  )»TSIGMA<  3  ) 

COMMON  /ANALYS/  IFSPGX, FRHOVG * F  VELOC  , F AZ IMF  ,  FVEVAR *  FAZVAR ,  I FST AT , 
CFMU<  4  >»FPSI<  4  )»FRH0(  6  ),IFMAX( 4  >.IFMIN(  4  ) , ITSPQX , TRHOVG * TVELOC , 

{ TAZIMF ,  TVEVAR ,TAZVAR  , ITSTAT  ,  TMU(  3  >,TF‘SI(  3  >,TRH0(  3  >,ITMAX(  3  >, 

CITMIN<  3  ) 

COMMON  /NISC/  ITMF’RY<  1536),  IFCNBR, I STAT » ITAI LR(  100).ITRGF:Y(  129  >, 

C CALLER, INRDIF  » INRCHL  » ITRMAX i F IMGRYC 256.4  ) 

COMMON  /WRKSPC/  IUKSPCC  1 152  )  »RH0ARY( 65 > , IEND , TEND , IDUM . TDIF , 
CRHONAX.FDIF 

DATA  IYES/l/f INO/-1/. THREE/ 1HT/.F0UR/1HF/.YEB/1HY/ 

. . . . routine  area . . . . . 

Compute  cross-correlations  (normalized  covariances >  between 
all  pairs  of  the  arrays. 

IF  (CALLER  .EQ.  THREE)  GO  TO  59 

Here's  the  four  element  (F)  analysis. 

I STAT  =  I NO 
INRDIF  =  6 

IF  (IFCNBR  .EQ.  3)  INRDIF  =  3 
FNRDIF  =  FLOAT(  INRDIF ) 

*  C 

64  DO  60,1  =  1, IFCNBR 

CALL  MAXMIN( I4CHNLC 1,1 ),IFMAX( I >,IFNIN(  I  )) 

IF  (IFSPOX  .EQ.  0)  GO  TO  60 

CALL  MUNPSK  I4CHNLC  1,1  ),FKU<  I  >,FPSI(  I  )) 

FSIGMA(I)  =  FPSKI)  -  FMU(  I  )**2 
»  IF  (FSIGMA(I)  .LE.  0.)  GO  TO  62 

FSIGMA(  I  )  =  SQRT<  FSIGMA< I  )  ) 

FPSK  I  )  =  SORT (  FPSI(  I  )  ) 

60  CONTINUE 

IF  (IFSF'QX  .EQ.  0)  RETURN 
C 

*  FRHOVG  =  0. 

IEND  *  IFCNBR  -  1 

JEND  =  IFCNBR 
M  =  1 

DO  61 , I  *  1,1 END 
K  =  I  +  1 

*  C 

DO  61,. J  *=  K  ,  JEND 

CALL  RTXC0V(  I4CHNLC 1*1 ),I4CHNL( 1 , J  ), IUKSPC, RHOARY  ) 


C 


RHOMAX  =  -10000 


noon 


FHIF  =  32. 

DO  63,  L  =  1,65 

IF  (RHOARY(L)  .LE.  RHOHAX)  GO  TO  63 
RHOHAX  =  RHOARY(L) 

FTDIF(H)  =  FDIF 
FDIF  =  FDIF  -  1. 

FRHO<  H  )  =  (  RHOMAX  -  FHU<  I  >*FHU<  J  )  )/<  FSIGHA<  I  )*FSIGHA<  J  ) ) 

FRHOVG  =  FRHOVG  +  FRH0<  H ) 

H  =  H  +  1 

FRHOVG  =  FRHOVG/FNRIHF 

JYEAR  =  IHPINGU8) 

CALL  BEHEST 
IFSTAT  =  ISTAT 

I  HUH  =  IUICHDR(  2  )  -  3 
IF  < IFSTAT  -  0 )  66,69.68 
TYPE  10, CALLER 
GO  TO  69 

IF  <  FRHOVG  .LT.  TRHOVG )  RETURN 
JDAY  =  IHPIWG<3) 

JHOUR  =  IHF'INGt  4 ) 

•JSEC  =  IHF'IMG<  5  ) 

JFLAG  =  0 

CALL  RTCLOKX  JFLAG, AMONTH, JDAY , JHOUR, JHIN, JSEC  ) 

TYPE  18, JHAY, ANONTH, JYEAR, JHOUR, JMIN, JSEC 

TYPE  12 , IDUM , IUKHDR< 2  >, 1FSPQX, FAZVAR , FVEVAR , FRHOVG , FA2I HF , FVELOC 
RETURN 


Here's  the  three  element  <T)  enelysis. 

ISTAT  =  INO 
DO  50,1  s  1,3 

CALL  HAXHIN< I3CHNL( 1,1 ),ITHAX( 1 ),ITHIN(  I )) 

IF  ( ITSPQX  .EQ.  0)  GO  TO  50 

CALL  HUNPSK  I3CHNLC 1,1  ),THU<  I  ),TPSI<  I  ) ) 

TSIGHAt  I  )  =  TPSI(I)  -  THU<  I  )**2 
IF  <  TSIGHAC I  )  .LE.  0.)  GO  TO  52 
TSIGNA< I  )  =  5QRT< TSIGHA< I ) ) 

TPSI< I  )  =  SQRT< TPSI(  I ) ) 

CONTINUE 

IF  (ITSPQX  .EQ .  0)  RETURN 

TRHOVG  =  0. 

H  =  1 

DO  51,1  =  1,2 
K  =  I  +  1 

DO  51, J  =  K» 3 

CALL  RTXCOV( I3CHNLC 1,1 ),I3CHNL< 1 > J  > , I WKSPC , RHOARY ) 

RHOHAX  =  -10000. 

TDIF  =  8. 

DO  53, L  =  1,65 

IF  (RHOARY(L)  .LE.  RHOHAX)  GO  TO  53 
RHOHAX  =  RHOARY(L) 

TTDIF(H)  =  TDIF 
TDIF  =  TDIF  -  .25 


o  n 


C 


TRHO(H)  =  <  RHOMAX  -  THU<  I  )*TMU<  J  )  >/<  TSIGMAt  I  )*TSIGMA<  J  ) ) 
TRHOVG  =  TRHOUG  +  TRHO(M) 

51  M  =  H  +  1 

TRHOVG  =  TRHOVG/3 ♦ 

INRIHF  =  3 
CALLER  =  THREE 
JYEAR  =  IHPIHG< 18 ) 

CALL  BEHEST 

52  ITSTAT  =  ISTAT 

IF  ( ITSTAT  -  0  )  56*57* 54 

56  TYPE  10. CALLER 
GO  TO  57 

54  IF  (TRHOYG  *LT .  FRHOVG  )  RETURN 

JDAY  =  INF'ING<  3  ) 

JHOUR  =  IMPING'  4  ) 

JSEC  =  IMPING<  5  ) 

JFLAG  =  0 

CALL  RTCLOK<  JFLAG *AMONTH. JDAY » JHOUR, JMIN » JSEC ) 

TYPE  18*  JDAY  * AMONTH* JYEAR  » JHOUR* JMIN* JSEC 

TYPE  13* IUKHHR(  2 ) *  IT SPQX* TAZVAR , TVEVAR* TRHDVG* TAZIHF , TVELOC 

57  COHTIMUE 


10  FORMAT  (  '  ' ,A1»3X»' ***INUALID  ANALYSIS!!***' »*> 

11  FORMAT  <'  ' *A1 ,3X*6F5.2*$ > 

12  FORMAT  ('  F',I6*'  to'  *  15* 3X» 14 , 2F6 . 1  * 3X* ' <  '  * F4 . 2  * '  >' * 2F8 ♦ 2* ♦ ) 

13  FORMAT  <'  T' *I6*11X*I4*2F6.1»19X>'< '  *F4 . 2. '  )' *2F8 . 2 1 $  > 

14  FORMAT  <'  ' »A1,2X,6F5.1*F5.2.*> 

15  FORMAT  <'  ' ,A1,2I6.3F7»1.$ > 

16  FORMAT  ('  ' ,A1,2X,3F6.2»12X»F5.2»*> 

17  FORMAT  <'  ' *A1,2X.3F5.2.* > 

18  FORMAT  <'  @' ,13*'-' *A3»'-' *12.14*' .f' *12*  '  ' *  12. ' "Z . ' »«  ) 


C 


RETURN 

END 


IbJFT  ANALYSIS  PROGRAMS 


These  programs  were  adapted  by  Bruce  MoKihben  from  software  developed  b« 

Jon  Olson.  They  are  designed  for  doing  extensive  analysis  on  single  blocKs 
of  data.  In  most  cases*  the  programs  are  restricted  to  data  strings  where 
the  number  of  points  is  a  power  of  two.  Most  of  these  programs  use  routines 
from  ANTLIB.  Program  BATGET  uses  the  MACRO  tape  handling  routines  from 
TAPEIO.OEU.  (TAF'EIO  is  included  in  MACLIP  in  this  book.)  These  programs 
may  be  found  on  disks  labeled  ANTWRK. 

In  the  following  descriptions*  a  datablock  refers  to  the  raw  data  as  it  is 
stored  on  the  tapes.  A  dataset  is  the  data  from  3  or  4  records  as  it  is 
stored  in  an  FTN  data  file  on  disk.  A  recordfile  is  the  data  from  one 
record  extracted  from  a  dataset*  and  is  also  stored  in  an  FTN  data  file  on 
disk  . 

ANLY7  A  program  which  calculates  the  correlation  coefficients*  arimuth  and 
velocity  from  a  dataset. 

BEMFIL.  A  program  which  filters  a  dataset  b«  use  of  the  beamsteer  vector 
at  a  specific  arimuth*  slowness*  and  freouency. 

1'tATGET  A  program  which  unwinds  a  datablock  from  the  magtape  and  returns  a 
dataset  for  each  arras. 

DATLST  A  program  which  lists  the  contents  of  a  recordfile  of  up  to  512  points. 

DATF'LT  A  program  which  creates  a  line  printer  Plot  of  a  recordfile. 

FKDETl  A  program  which  produces  a  detection  "map"  over  user  specified  ranges 
of  azimuth  and  slowness  at  a  user  specified  freouency. 

FK.DET2  A  program  similiar  to  FKDETl*  but  produces  a  data  message  in  FTN17.DAT 

MODEM  A  MACRO  routine  which  converts  ASCII  code  to  BAUDOT  code*  and  outputs 
a  message  file  to  the  teletype  <PCt>. 

F'OLFIL  A  program  which  filters  a  long  dataset  by  use  of  the  freouency 
dependent  degree  of  polarisation*  and  a  sliding  window  method. 

PURE Fl.  A  program  which  filters  a  dataset  by  use  of  the  freouency  dependent 
degree  of  pol arisation . 

Fv’ECGFT  A  program  which  extracts  a  recordfile  from  a  dataset. 

RPCTRM  A  Program  which  calculates  the  power  and  trace  spectrums  of  a  dataset. 

SPEKT2  A  program  which  calculates  the  power*  coherency*  Phase  and  trace 
spectrums  for  a  pair  of  records. 


C*****************  ANLYZ.FQR  t************************************** 

C 

C  Bate  of  revision*.  2&-Jul-82 

C 

PROGRAM  ANLYZ 
C 

C  PURPOSE 

C  To  perform  time  series  analysis  on  a  dataset 

C 

C  USAGE 

C  RUN  ANLYZ 

C 

C  INPUT  PARAMETERS 

C  IBKNR  -  BIocK  number  of  dataset 

C  NARRAY  -  Arre«  type  <1  if  n-6»  0  if  n-7 ) 

C  NREC  -  Number  of  records  (3  or  4) 

C  NOP  -  Number  of  points  for  analysis 

C  NSTRT  -  First  Point  for  analysis 

C  MREC  -  Missing  channel  < 0*1 ,2*3, 4*5*6  or  7) 

C 

C  REMARKS 

C  UnliKe  the  other  analysis  programs*  this  program  does  not  use 

C  the  FFT »  and  therefore*  NOP  is  not  limited  to  powers  of  2. 

C  Provision  is  made  in  this  program  for  the  future  expansion  of 

C  the  n-6  array  to  four  channels .  Uhen  this  is  done*  the  X  and  Y 

C  coordinates  of  the  new  station  should  be  inserted  as  indicated* 

C 

C  LIBRARIES  REQUIRED 

C  ANTLIB*  SYtFORLIB 

C 

C  METHOD 

C  The  NOP  point  segment  from  each  data  string  is  selected  from  the 

C  raw  data*  The  cross-correlations  between  pairs  are  calculated* 

C  and  the  results  used  in  the  least-souares  determination  of  the 

C  azimuth  and  velocity  of  the  signal* 

C 

COMMON  /AZIMUT/  THETA, VEL .CTHETA, CVEL 

COMMON  /CORPAS/  BELT(  6  ) . CORR<  6  )  ,DELX<  6  )  *  DELY(  6  )  *N0SP  *MREC 
COMMON  /BATPAS/  DATA(  512 .4  )  *FXI< 512 *4  )*NOP .NSTRT .NARRAY . IREC 
DIMENSION  X<  4 ),Y<4  ) 

EQUIVALENCE  (  X(  1  ).FXI(  1*1  ))»<Y<  1  )*FXI<5,1  )) 

C . . * . . . . 

C 

C  Program  initialization  area 

C 

TYPE  5 

5  FORMAT  ('  ENTER  IBKNR, NARRAY *NREC. NOP. NSTRT'  > 

ACCEPT  10,1 FKNR » NARRAY , NREC , NOP , NST  RT 
10  FORMAT  <5110) 

IF  (NSTRT  *EQ.  0)  NSTRTal 
IF  <  NOP  *EQ.  0)  N0P=512 
IF  (NREC  .EQ.  0)  NREC=4 
MREC=0 

IF  (NREC  .EQ.  4)  GO  TO  20 
TYPE  15 

15  FORMAT  ('  ENTER  MISSING  CHANNEL') 

ACCEPT  10* MREC 
MREC=NREC+1 

IF  (NARRAY  .EQ .  1)  NREC=MREC-4 
20  N0SP=NREC 


IF  <  NOSP  .EQ.  4)  NOSP=6 
X<  1  )=0 . 

Y(  1  >=0. 

IF  <  NARRAY  .EQ.  1 )  QO  TO  25 
X(  2  )=-2405 . 5 
Y<  2  )=5657 .9 
X<  3  )=5458.7 
Y<  3 >=3098. 9 
X<  4  >=3685.3 
Y(  4  )=-1056.7 
NUNIT=11 
KREC=4 
GO  TO  30 
25  X<  2  )*-7  *6 

Y<  2  >=1125.87 
X<  3  )=945  •  8 
Y(  3  )=578 . 8 

C  The  comment  fleas  should  be  removed  from  these  statements*  and 

C  the  values  of  the  new  station  location  should  be  inserted*  when 

C  the  small  array  is  expanded  to  four  channels.  The  value  of  KREC 

C  should  be  chanded  to  4. 

C  X<  4  )=0 . 

C  Y<  4  )=0 . 

KUNIT=12 

KREC=3 

C  The  follouind  statement  should  be  removed  when  the  new  station 

C  is  added  to  the  system. 

HREC=4 

30  READ  (KUNIT)  < < DATA< J*I >*J=1 *512 >* 1=1 *KREC > 

NREC=4 

C . 

c 

C  Set  up  station  pairs  to  be  used  for  analysis 

C 

N=0 

NREC1=NREC-1 
DO  40  IX=1 . NREC1 

IF  < IX  .EQ.  HREC  )  GO  TO  40 
KY=IX+1 

DO  35  I Y=KY »NREC 

IF  < IY  .EQ.  HREC  )  GO  TO  35 
N=N+1 

DELX<  N  )=X<  IX  )-X<  IY  ) 

DELY<  N  )=Y( IX  )-Y< IY  ) 

35  COKTINUE 

40  CONTINUE 

C . . . . . . . . . . . . . 

c 

C  Call  analysis  subroutines 

C 

DO  45  IREC=1 *NREC 

IF  <  IREC  .EQ.  HREC)  GO  TO  45 
CALL  SELECT 
45  CONTINUE 

CALL  XCORR 
CALL  LSQRS 

C . . . . . . . 

C 

C  Output  results 


AUC0RR=0 . 

DO  50  N=1»N0SP 

AVCORR=AUCORR+CORR< N  > 

WRITE  <  7  »55  )  N»DELT( N  ),CORR( N  ) 

CONTINUE 

FORMAT  < 16»  2F 10 .3  ) 

AVCORR=AVCORR/NOSP 

WRITE  <7.60>  1RKNR»  AUCORR  »THET A  »CTHETA» VEL  » CVEL 
FORMAT  < I5*11X»F5.3>2X,2F10.3»8X»2F10.3  > 

CALL  EXIT 
END 


noon 


C **************  BEKFIL .FOR  **************************************** 

C 

C  Date  of  revision.  2&-Jul-82 

C 

PROGRAM  BEMFIL 
C 

C  PURPOSE 

C  To  filler  s  3  or  4  channel  lime  series  through  Ihe  application 

C  of  Ihe  freouency  dependent  beam-steer  veclor  lo  Ihe  transform 

C  of  Ihe  lime  series 

C 

C  USAGE 

C  RUN  BEMFIL 

C  The  dslssel  must  be  slored  in  FTN11.DAT  or  FTN12.DAT 

C  The  filtered  dslssel  is  returned  to  FTN21.DAT  or  FTN22.BAT 

C 

C  INPUT  PARAMETERS 


c 

IBKNR 

- 

BlocK  number  of  dataset 

c 

NARRAY 

- 

Array  type  (1  if  n-&*  0  if  n-7 ) 

C 

NREC 

- 

Number  of  records  <3  or  4) 

c 

NSMO 

- 

Number  of  smoothings 

c 

IG 

- 

Power  factor  for  filter  sharpening 

c 

NOP 

- 

Number  of  data  points  (must  be  a  power  of  2 ) 

C 

NEST 

- 

Freouency  estimate  for  beam-steer 

c 

SLOW 

- 

Slowness  for  beam-steer 

c 

THETA 

- 

Azimuth  for  beam-steer 

c 

r 

MREC 

- 

Missing  channel  < 0. 1 .2. 3. 4. 5. 6  or  7) 

w 

c 

REMARKS 

C  Provision  is  made  in  this  program  for  the  future  extension 

C  the  n-6  array  to  four  channels.  Uhen  this  is  done,  the  two 

C  station  coordinates  should  be  inserted  as  indicated  below. 

C 

C  LIBRARIES  REQUIRED 

C  ANTLIB.  SY'.FORLIB 

C 

C  METHOD 

C  The  state  vector  is  calculate  front  NEST.  SLOW,  and  THETA,  and 

C  is  passed  to  the  subroutine  for  filtering 

C 

COMMON  /DATPAS/  HAT A< 512 » 4  ) . FXI ( 51 2  *  * >. NOP . IG. NARRAY . IREC 
COMMON  /DETEK/  PETR<  50.50).  IDIREC.MREC 

COMMON  /SPEC/  SKATR<  256  )»TRACE( 256  l.NREC.NHALF .NSM0.FN0P 
DIMENSION  AR<  4  >»AI<  4  ).X<  4  >.Y<  4  ) 

EQUIVALENCE  <  ARC  1  )» DETR<  1 .50  )  )>(  AI<  1  )»DETR<  5.50  )  ) 

EQUIVALENCE  <  X<  1  ),DETR<  9.50  )  ).<  Y<  1  )»BETR<  13.50  )  ) 


Program  initialization  area 
TYPE  5 

5  FORMAT  ('  ENTER  IBKNR . NARRAY , NREC . NSM0. IC » NOP'  > 
ACCEPT  10 . IBKNR. NARRAY . NREC . NSM0 » I G . NOP 
10  FORMAT  (6110) 

TYPE  15 

15  FORMAT  ('  ENTER  NEST . SLOW , THETA'  ) 

ACCEPT  20.NEST .SLOW. THETA 
20  F0RMAT< I10.2F10.4 ) 

IF  <  NOP  ,EQ.  0)  N0P=512 
IF  ( IC  .EQ.  0)  16=1 


l 


oooo  oo  n  n  o  n  o  o 


IF  ( NSNO  . EQ .  0)  NSM0=3 
IF  (MREC  . ED .  0)  NREC=4 
MREC=0 

IF  (NREC  .Ed.  4)  GO  TO  30 
TYPE  25 

25  FORMAT  ('  ENTER  MISSING  CHANNEL') 

ACCEPT  lOfMREC 

TYPE  65»THETA, SLOW, NEST, IBKNR* IGfMREC 
NREC=MREC+1 

IF  (NARRAY  .EQ.  1)  MREC=HREC-4 
GO  TO  35 

30  TYPE  60, THETA, SLOW, NEST  , IBKNR  » IG 
35  X(1)=0. 

Y<  1  )=0 . 

IF  (  NARRAY. EQ. 1  )  GO  TO  40 

KREC=4 

X(  2  )=-2 . 406 

Y  (  2  )=5 . 658 
X-:  3  )=5 .459 
Y<  3  )=3 . 099 
X(  4  >=3.685 
Y(  4  )=-l  . 057 
IUMIT=1 1 

FREQ=FLOAT( NEST-1 )/512. 

GO  TO  45 

40  X( 2  )=-0 . 008 
Y<  2  )=1 . 126 
X( 3  >=0.946 
YC  3  )=0 . 579 

The  comment  fleas  should  be  removed  from  these  ststements»  end 
the  values  of  the  new  station  location  should  he  inserted*  when 
the  smell  array  is  expanded  to  four  channels.  The  value  of  KREC 
should  be  chended  to  4. 

X<  4  )=0 . 

Y  (  4  )=0 . 

KREC=3 

IUNIT=12 

FREQ=FLOAT( NEST-1 )/128. 

The  followina  statement  should  be  removed  when  the  new  station 
is  added  to  the  system. 

MREC=4 
45  NREC=4 

NHALF=N0P/2 
FN0P=FL0AT < NOP  ) 

T0PI=2 . *3 . 14 159 
RAIi=T0PI/360. 

0MEG=T0PI*FREG 
THET  A=THET  AfcRAIi 
CST  =C0S< THETA) 

SST =8IN< THETA) 


Calculate  stete  vector 


AMAG=0. 

BO  50  IREC=1  »NREC 

IF  (IREC  .EQ.  MREC )  GO  TO  50 

TAU=SL0U*<  (  X(  IREC  )-X<  1  )  )*SST+(  Y<  IREC  )-Y(  1  )  )*CST  ) 

ARG=ONEG*TAU 

AR<  IREC  )=C0S<  ARG  ) 


AI <  IREC  >=SIN<  ARG  ) 

AMAG=AMAG+AR( IREC  >**2+AI<  IREC  )**2 
50  CONTINUE 

DO  55  IREC= 1 » NREC 

IF  (IREC  .  EB .  NREC)  GO  TO  55 
AR(  IREC  )=AR<  IREC  )/AMAG 
AI (  IREC  )=AI<  IREC  )/AMAG 
55  CONTINUE 

C . * . 

c 

C  Filter  dste 

C 

READ  <  I  UNIT  >  <<  BAT A<  J*  IREC  >.J  =  1  »NOF' >*IREC=1  »KREC  > 

CALL  BEAMFL 
IUNIT=IUNIT+10 

WRITE  (  IUNIT  )  (<DATA< J > IREC > » J  =  1  * NGP  )» IREC=1 .KREC  ) 

60  FORNAT< '  BEANFILTER  AT  '.FS.li'DEG  ' * F3 . 1 . ' S/KM  NEST='*I2./ 
6  15X,  'BLOCK  *'  »I5*'  IG=',I1> 

65  FORMAT (  '  BEAMFILTER  AT  '  »F5. 1  * ' DEG  '»F3.1»'S/KM  NEST='»I?*/ 

6  15X>'BL0CK  *' f I5»'  I G  = ' » 1 1  * '  CHANNEL ' » 12  t '  MISSING' 

CALL  EXIT 
END 


o  <"*  a  a  oooo  noon  ooononnonnoononnnnonnooo  non 


C**********************  DATGET .FOR  #**********************)U****t 
Dele  of  revision:  20-Aug-82 
PROGRAM  DATGET 
PURPOSE 

To  reed  end  unwind  date  from  the  tape  (Rev  10  to  Rev  17) 
USAGE 

RUN  ItATGET 

F  array  data  is  returned  to  FTN11.DAT 
7  array  data  is  returned  to  FTN12.DAT 

INPUT  PARAMETERS 

IBKNR  -  Starting  block  number 

REMARKS 

F  array  data  is  returned  for  the  512  second  period  starting 
with  IBKNR.  T  array  data  is  returned  for  the  128  second 
period  of  IBKNR. 

LIBRARIES  REQUIRED 
TAPEIOjSYIFORLIB 

METHOD 

The  tare  is  advanced  to  the  desired  starting  block.  Four 
blocks  of  data  are  read  and  unwound  into  FTN11.  Only  the 
first  block  read  is  unwound  into  FTN12. 

DIMENSION  I  HE  A  IN  20  ) * IHAT<  2048  >*ITAP<  2168>,T0T<  7  >*DATA<  512*7  ) 
EQUIVALENCE  <  IHEAIK  1  )*ITAP<  1  )),<  IIlATt  1  )»ITAP<21  )) 


Program  initialization  area 
IUNIT=0 

CALL  INITAP(  IUNIT.800, 1 .ISTATU  ) 
TYPE  100 

ACCEPT  105 » IBLOCK 
DO  5  N= 1  *  7 

T0T( N  )=0 , 

5  CONTINUE 

MBL0CK=IBL0CK-1 


Tare  positioning  area 

10  CALL  REDTAPC IUNIT» I TAP*  4336 » I STATU  > 
IF  < ISTATU+0  )  15*15*25 
15  TYPE  20* ISTATU 
20  FORMATt '  TAPEREAD  ERROR  '*118) 

GO  TO  95 

25  IF  ( ITAP(  2  >-MBL0CK )  30*35*30 
30  IC0UNT=MBL0CK-ITAP<  2  )-l 

CALL  SPCTAP  < IUNIT.IC0UNT.ISTATU) 

GO  TO  10 


Bad  Block  detection  area 


nnoo  noon  noon 


35 

MTAF‘=ITAP(  2) 

NT AP=  IT AP<  4  ) 

DO  85  N=1 *4 

40 

CALL  REDTAP< I UNIT . ITAP » 4336 
IF  ( 1ST ATU+0 )  45» 45 1 50 

f ISTATU  ) 

45 

TYPE  20» ISTATU 

GO  TO  85 

50 

IF  (  ITAP(  2  KNE.MTAP  )  GO  TO 

<40 

IF  < ITAP<  4  )  .HE ♦ NTAP  )  GO  TO 
TYPE  55 * ITAP<  2 ) 

60 

55 

FORMAT(  '  BAD  BLOCK  *'*I5> 

GO  TO  40 

<40 

MTAP=ITAP<  2 ) 

NTAP=ITAP(  4 ) 

F  array  data  unwind  area 

TYPE  105» ITAP<  2  ) 

DO  70  L=1 » 128 
DO  65  K=l»4 

LL=( N~1  )*128+L 

DATA(  LL  »K  )=FL0AT<  II»AT<  K+l 6*L-16  )  ) 
T0T(K)=T0T<  K)+IiATA(LL»K> 

<45  CONTINUE 

70  CONTINUE 


T  array  data  unwind  area 

IF  <  N.NE.l  )  SO  TO  85 
DO  80  K=5»7 
L=  1 

DO  80  J=1 *  128 

DO  75  M=1 » 10»  3 

DAT A(  L  »  K  >=FLOAT ( IBAT( M+K+ 16*J-1 7 ) ) 
T0T<  K  >=T0T<  K  )4DATA<  L  »K  ) 

L=L+ 1 

75  CONTINUE 

80  CONTINUE 

85  CONTINUE 


Data  output  area 


90 


95 

100 

105 


DO  90  K=1 »7 

DO  90  L-l • 512 

DATA<  L  »K  )=DATA<  L  »K  )-T0T<  K  >/51 2 . 

CONTINUE 

WRITE  <11)  (<  DATA(L*K)»L  =  1»512  >»K=1 ,4  > 
WRITE  (12)  <<DATA<L»K)fL  =  lf512  )fK=5»7) 
CALL  EXIT 

FORMAT  < '  INPUT  BLOCK  NUMBER'  > 

FORMAT  (110) 

END 


I 


o  n  o 


C»*******>U********  DATLST .FOR  tK.****t**t*t*ttt***t*tttt**tttttttt 

Date  of  revision:  14--May-82 

PROGRAM  DATLST 
C 

C  PURPOSE 

C  To  maKe  the  date  in  a  recordfile  available  to  the  terminal 

C 

C  USAGE 

c  run  datlst 

C 

C  INPUT  PARAMETERS 

C  NOP  -  Number  of  points  in  recordfile 

C  INFILE  -  Logical  unit  of  recordfile 

C 

C  REMARKS 

C  None 

C 

C  LIBRARIES  REQUIRED 

C  SYtFORLIB 

C 

C-  METHOD 

C  The  data  is  resd  into  an  array  which  is  then  printed 

C 

DIMENSION  DATA<  512  ) 

TYPE  5 

5  FORMAT ( '  ENTER  NOP, INFILE'  ) 

ACCEPT  10, NOP, INFILE 
10  F0RMAT<  216  ) 

READ  (INFILE)  <  DATA(  J  ),<J=1  ,N0P  ) 

WRITE  (7,15)  <  DAT A<  J  ) ,  J=  1 » NOP  ) 

15  FORMAT  (5F15.2) 

CALL  EXIT 
END 


noon  noon  ooonoonoononononoooo  ooo 


C**************  DATF'LT  .FOR  ****%************X*********t*X**t*X****X*** 
Pete  of  revision:  13-May-82 
PROGRAM  DATF'LT 
PURPOSE 

To  produce  a  riot  of  s  recordfile  on  the  line  printer 
INPUT  PARAMETERS 

NOP  -  Number  of  points  to  be  Plotted 
INFIL  -  Logical  unit  of  recordfile 
YMIN  -  Minimum  value  of  vertical  axis 

YMAX  -  Maximum  value  of  vertical  axis 

REMARKS 
None 

LIBRARIES  REGUI RED 
SYJFORLIB 

METHOD 

An  asterisk  is  placed  in  each  line  printer  line  corresponding 
to  the  scaled  value  of  the  data  point. 

L0GICAL*1  AST* DOT, DASH, CROSS, BLANK, TEMP 
DIMENSION  Y( 512  ) 

LOGICAL)*  1  LINE(  80  ) »  RULE<  80  > 

DATA  AST,  DOT,  DASH,  CROSS,  BLANK  '  '/ 


Program  initialization  area 


ISC=0 
TYPE  10 

10  F0RMAT( '  ENTER  NOP, INFILE, YMIN, YMAX'  > 
ACCEPT  20, NOP, INFIL, YMIN, YMAX 
20  F0RMAT<  2I5»2F10.4  ) 

READ  (INFIL)  <  Y<  I  ) ,  1  =  1 ,  NOP  ) 

IF  ((YMAX. NE.O). OR. (YMIN. NE.O))  GO  TO  30 
YMAX=-10000. 

YNIN=10000. 

DO  30  1=1, NOP 

IF  (  Y(  I  l.GT.YNAX  )  YMAX=Y( I  > 

IF  (  Y(  I  ).LT.YMIN)  YMIN=Y(  I  ) 

30  CONTINUE 


Horizontal  axis  set-up  area 

RANGE= YMAX- YMIN 
TYPE  40, YMIN, YMAX 
40  FORMATC 1X»F6.1»T75»F6.1 ) 

DO  50  1=1,80 
RULE(  I  )=D0T 
50  CONTINUE 

DO  60  1=1,80,8 
RULE(  I  )=CR0SS 
40  CONTINUE 

TYPE  70, (  RULE(  I ), 1  =  1 , 80 ) 


o  o  o  o 


ml1  11  -  111  — «  »-jxr 

70  F0RttAT< 1X»80A1  ) 


Plot  area 

DO  80  1=1 »80 

LI NEC  I  >=BLANK 
80  CONTI HUE 

LINE<  1  >=CR0SS 
DO  90  1  =  1 » NOP 

DIST=<  Y( 1  )-YHIN  )/RANGE 
IP=IF1X<  D1STC80.  )+l 
7ENP=LINE(  IP  > 

LI  NEC  IP  )=AST 

TYPE  70*C LINEC II >»II=1 ,80 > 
LINEC IP  )=TENP 
90  CONTINUE 

TYPE  70 »(  RULE(  I  )»I  =  1»80  ) 

TYPE  40 1 YNIN»  YNAX 

CALL  EXIT 

END 


» 


» 


» 


» 


» 


» 


nnnoooonrjoonnooonnnonoonnnnnnoonoonnoooo  ooo 


C#********st :**********  FKDET1  .FOR  t*********************************** 
Date  of  revision.  18-Aug-82 
PROGRAM  FKItETl 
PURPOSE 

To  produce  s  50  by  50  slowness- theta  diagram 

USAGE 

RUN  FKHET 

Input  data  is  read  fro*  unit  11  or  12 
The  diagram  is  output  to  unit  7  (default  TT5  ) 

INPUT  PARAMETERS 

IBKNR  -  Block  number  of  dataset 
NARRAY  -  Array  type  < 1  if  n-6»  0  if  n-7  ) 

NREC  -  Number  of  records  < 3  or  4) 

NSMO  -  Number  of  smoothings 
IG  -  Power  factor  for  detector  sharpening 
NOP  -  Number  of  data  points  (must  be  a  power  of  2  ) 

MREC  -  Missing  channel  ( 0* 1 *2*3*4»5»6  or  7) 

THMIN  -  Minimum  value  of  theta  for  diagram 

THMAX  -  Maximum  value  of  theta  for  diagram 

SLMIN  -  Minimum  value  of  slowness  for  diagram 
SLMAX  -  Maximum  value  of  slowness  for  diagram 
EST  NR  -  Estimate  number  of  frequency  for  analysis 
DMIN  -  Minimum  detector  value  to  be  output 

DNAX  -  Maximum  detector  value  to  be  output 

REMARKS 

Provision  is  made  in  this  program  for  the  future  expansion  of 
the  n-6  array  to  four  channels.  When  this  is  done»  the  X  and  Y 
coordinates  of  the  new  station  should  be  inserted  before 
statement  7. 

LIBRARIES  REQUIRED 

antlib,sy:forlib 

METHOD 

A  beam-steer  state  detector  is  applied  to  the  spectral  matrix 
at  the  specified  frequency.  To  save  memory  space*  the  spectral 
matrix  is  determined  at  seven  freeuencies  near  the  specified 
freouencw.  These  are  smoothed*  then  all  but  the  freouencv  of 
interest  are  discarded. 


COMMON  /DATPAS/  PAT A( 51 2 » 4 ) * FXI ( 512 *4 >» NOP »MREC » NARRAY * IREC 
COMMON  /BETEK/  DETR(  50 , 50 ) » IBIREC* INULL 
COMMON  /SPEC/  SNATR( 256  )*TRACE(  256  )  *NREC*NHALF . NSMO *FNOP 
DIMENSION  IDET(  50  )*AR(  4  )* AI(  4  )»SPMR(  9  )*SPMI(  9  ) 

DIMENSION  TENPR(  4  )rTEKPI(4  >*X(  4  >*Y(4  >»SLAN(  5  >»SLVAN(5> 
DIMENSION  SPM AR<  4*4  )»SPNAI(  4*4  )*NUMBS(  50  ) 

EQUIVALENCE  (  1BETC  1  )*SMATR(  1  )  >*(  AR(  1  )*SMATR(  51  )  ) 

EQUIVALENCE  (  AI(  1  ),SNATR(  55  )  >,(  TENPR(  1  )*SMATR(  59  )  > 
EQUIVALENCE  (  TENPI<  1  )»SMATR<63  )  )*(SLAN(  1  )*SNATR(  67  )  ) 
EQUIVALENCE  ( SLVANC 1  ).SMATR(  72  )  ) 

EQUIVALENCE  (  SPMR(  1  ).SMATR(  150  )  )*(  SPNI(  1  )*SKATR(  160  )  ) 
EQUIVALENCE  ( SPMAR(  1*1  )*SNATR( 170  )  )*(SPNAI(  1*1 >*SKATR(  190  > ) 


C 

» 

I 

C 


I 


I 


V 


t 


» 


I 


t 


» 


» 


C  Program  ini lisl i2siion  area 

C 

TYPE  2 

2  FORMAT  < ' OENTER  IBKNR»NARRAY tNREC » NSHO » IG. NOP'  > 

ACCEPT  3 » I BKNR , NARR AY . NREC  ? NSKO » I G  ? NOP 

3  FORMAT  <6110) 

IF  (NOP  .EG.  0)  N0P=512 
IF  <IG  .EG.  0)  IG= 1 
IF  <  NSMO  .EG.  0)  NS MO =3 
IF  <  NREC  .EG.  0)  NREC=4 
MREC=0 

IF  (NREC  .EQ.  4)  GO  TO  5 
TYPE  4 

4  FORMAT  ('  ENTER  MISSING  CHANNEL'  > 

ACCEPT  3.MREC 

NREC=NREC+1 

IF  (NARRAY  .EG.  1)  MREC=MREC-4 

5  SINT=1 . 

IF  (NARRAY. EQ. 1  )  SINT=.25 
X<  1  )=0 . 

Y  (  1  )=0. 

IF  ( NARRAY, EG. 1  )  GO  TO  6 

KREC=4 

IUNIT=1 1 

X(  2  )=-2 . 406 

Y<2)=5.658 

X(  3  )=5 . 459 

Y< 3  )=3 . 099 

X<  4  )=3 . 685 

Y<  4  )--l .057 

GO  TO  7 

6  IUNIT=12 

X(  2  )=-0 . 008 
Y<  2  )=1 . 126 
X(  3  )=0 . 946 
Y<  3  )=0»579 

C  The  comment  flags  should  he  removed  from  these  statemen ts?  and 

C  the  values  of  the  new  station  location  should  be  inserted?  when 

C  the  small  ar raw  is  expanded  to  four  channels.  The  value  of  KREC 

C  should  he  changed  to  4. 

C  X<  4  )=0 » 

C  Y<  4  )=0 . 

KREC=3 

C  The  following  statement  should  be  removed  when  the  new  station 

C  is  added  to  the  sustem. 

MREC=4 

7  NREC=4 
NHALF=N0P/2 
FNOP=FLOAT<  NOP  ) 

FZR0=1 ♦ /<  SINTfFNOP ) 

PI=3. 14159 
T0PI=2.*PI 
RAD=PI/180. 

READ  ( IUNIT  )  <  <  BATA<  J » I  ) » J-l »N0P  ) » 1  =  1 » KREC  ) 

C.  . . . . . 

C 

C  Transform  to  freeuencv  domain  and  determine  maximum  rower 


CALL  SPECTR 


noon  o  o  o  o 


TNAX=-1.E10 
PO  IS  J=1 .NHALF 

IF  <  TNAX  . GE  * TRACE<  J  > )  CO  TO  15 
7HAX=TRACE<  J ) 

FNAX=SMATR<  J ) 

NAXJ=J 

15  CONTINUE 

TYPE  20  *  TNAX  » FNAX » MAX J  * NHALF 
20  FORMAT  < ' OMAXPOUER t ' »E15.3. '  AT' »F 10.4.' 
♦  /  »5X» ' <  ESTIMATE '  » 15. '  OF'.IS.')') 


Set  ur  range  of  slowness-theta  diagram 

25  CONTINUE 

DETNAX=-1  . 

TYPE  30 

30  FORMAT  < ' OENTER  THNIN.THNAX'  ) 

READ  (5.35)  THNN.THNX 
35  FORMAT  (2F10.5) 

IF  < ( THMN  .NE.  0.)  .OR.  < THNX  .NE.  0.))  CO 
THMN=0 . 

THMX=360. 

37  THMN=THNN*RAD 
THMX=THNX*RAB 
DTH=< THMX-THMN  )/50. 

TYPE  40 

40  FORMAT  <'  ENTER  SLNIN.SLMAX'  ) 

READ  <5.35)  SLMN.SLNX 

IF  <  <  SLMN  .NE.  0.)  .OR.  <SLMX  .NE.  0.))  CO 
SLMN=0 . 

SLNX=5. 

42  DS=<  SLMX-SLMN  )/50 . 

TYPE  44 

44  FORMAT  <'  ENTER  EST .  NR'  ) 

READ  <5»3>  K 

IF  <  K  .EQ.  0)  K=MAXJ 

FREQ=FZR0*FL0AT<K-1  > 

OHEG=TOPI*FREQ 


'Calculate  spectral  matrix 


»  KM=K-4 

XP=K+4 

IF  <  KM.LE.O  )  KM=1 

IF  < KP.CT. NHALF  )  KP=NHALF 

KM1=KM+1 

KP1=KP-1 

»  IF  (K.LT.KNl  )  K=KN1 

IF  <  K.GT.KP1  )  K=KP1 
KS=KP-KM+ 1 
KS1=NP1-KM1+1 
TMAX=0, 

DO  49  1=1 »NREC 

•  IF  < I  .EQ.  MREC  )  CO  TO  49 
DO  48  J=1»NREC 

IF  (J  .EQ.  NREC )  CO  TO  48 
DO  45  N=1 »KS 
KT=KM+M-1 

• 


HERTZ'  . 


TO  37 


TO  42 


SPMR!  N  )=KATA!  KT » I  )*DATA<  KT .  4  >+FXI!KT»I  )*FXI!KT.4) 

SPNI!  M  )=FXI!  KT  .  I  )*DATA!  KT  .4  )-DATA!  KT  » 1  >*FXI<  KT  .4  > 

45  CONTINUE 

DO  47  I SNO= 1 »  NSNO 
DO  46  H=2 » KS1 

SPMR!  M)=.5*C  SPMR!  MH.  5*!  SPMR!  H-l  )+SPMR!M+l  >)) 

SPMKN  >=.5*<  SPHI<  M  H.5*!  SPNI!  H-l  >+SPMI!M+l  ))) 

46  CONTINUE 

47  CONTINUE 
M=K-KMl+2 

SPNAR<  I*  J  )=SPNR<  N  ) 

SPMAI<  I»J  )=SPMI<  N  ) 

48  CONTINUE 
TMAX=TNAX+SPNAR! 1*1) 

49  CONTImoE 

C . . . . . 

C 

C  Calculate  detector  level  for  each  value  of  slowness  and  theta 

C 

DO  85  ITH= 1*50 

THETA=THMN+FLOAT< ITH-1  )*BTH 
DO  80  ISL=1 *50 

SLOU=SLNN+FLOAT< ISL-1  )*DS 
C 

C  Calculate  state  vector 

C 

SUS=SLOW*SIN<  THETA  ) 

SUC=SLOU*COS<  THETA  ) 

AR<  1  )=1 . 

AI(  1  )=0. 

DO  50  1=2 » NREC 

IF  (I  . EQ •  NREC  )  GO  TO  50 

TAU=<  X<  I  )-X!  1  )  )*SVS+!  Y(  I  )-Y<  1  )  )*SVC 

AR(  I  )=C0S<  0NEG*TAU  ) 

AI<  I  )=SIN<  OMEGCTAU  ) 

50  CONTINUE 
AMAG=0. 

DO  55  1=1. NREC 

IF  <1  , EQ ♦  NREC  )  CO  TO  55 
AMAG=AMAG4AR! I  )**24AI! I  )**2 
55  CONTINUE 

ANAG=SQRT<  AMAG  ) 

DO  60  1=1 .NREC 

IF  < I  .EQ.  HREC  )  CO  TO  60 
AR<  I  )=AR<  I  )/ANAG 
AI< I )=AI(  I  )/ AMAC 
TENPR<  I  )=0. 

TEMPI!  I  )=0 . 

60  CONTINUE 

C 

C  Impress  state  vector  on  spectral  matrix 

C 

DETR< ITH.ISL )=0. 

DO  70  1=1 .NREC 

IF  < I  .EQ.  MREC  >  GO  TO  70 
DO  65  4=1 . NREC 

IF  ! 4  .EQ.  MREC)  CO  TO  65 

TEMPR<  I  )=TEHPR<  I  )+SPMAR<  I  »J  )*AR(  4  )-SPMAI<  I  .J  >*AI!  4  ) 
TEMPI!  1  )=TEMPI!  I  HSPMAR!  I  .4  )*AI!  4  l+SPMAI!  1.4  )*AR!  4  ) 
65  CONTINUE 


noon 


70  CONTINUE 

1*0  75  J=1,NREC 

IF.(J  .ECU  MREC )  CO  TO  75 

D=(  TEMPR(  J  >*AR(  J  >+TEHPI(  J  )*AI(  J  )  )/TNAX 

DETR(  ITHf  ISL  >=DETR(  ITH,  ISL  >+(D**IG  > 

75  CONTINUE 

IF  <  BETR(  ITH»  ISL  UGT.DETMAX  )  DETMAX=DETR(  ITH,  ISL  ) 
80  CONTINUE 

85  CONTINUE 


Slouness-thets  diagram  output  area 

90  CONTINUE 

TYPE  95.DETNAX 
TYPE  96 

ACCEPT  35,BMIN,I*MAX 

IF  ( DMAX.NE.O.  )  GO  TO  100 

95  FORMAT  ( 15X* '  ARRAY  MAX  t ' »F7 .3,/  > 

96  FORMAT  ('  ENTER  BMIN»DMAX' ) 

BNAX=I*ETNAX 

DMIN=DETMAX*.707 

100  DRANG=DMAX-DMIN 

WRITE  <  7 » 105 )  IBKNR.K 
WRITE  (7,103)  UMAX » DM IN 

103  FORMAT  ('  ARRAY  MAX.*  ',F6.3,'  ZERO  CONTOUR  AT.*  ',F6.3> 
105  FORMAT  < ' 1F-K  DETECTION  AT  BLOCK', 15,'  FRED  ESTIMATE' ,13,/ > 
SLVAN( 1 >=99999.99 
DO  110  1=1,5 

SLAN( I  )=SLMN+FLOAT( 1-1  )*BS*10. 

IF  <  SLAN< I  ).E6.0.  )  GO  TO  110 
SLVANC  I  >=1000  «/SLAN(  I  > 

110  CONTINUE 

WRITE  (7,115)  <  SLVAN(  I  >,  1  =  1 ,5  > 

115  FORMAT  ('  ' ,5X,5F10.2,'  M/S') 

WRITE  (7,120)  (  SLAN(  1  ),  1  =  1 ,5  ) 

120  FORMAT  (5X»5F10.3) 

WRITE  (7,125) 

125  FORMAT  ('  '  ,T12 ,'  +  ' ,T22  ,'+' ,T32 ,'+' ,T42  ,'+',  T52  ,'•»■'  ) 

DO  140  1=1,50 

THAN=( 1-1 )*DTH/RAD+THMN/RAD 
DO  130  J=1 ,50 

ID=IFIX(  9.9*(  DETR(  I,J  )-I*MIN  )/DRANG  ) 

IF  ((  ID.LE.O  ).0R.(  ID.GE.10))  II*=0 
NUMBS(  J  )=IB 
130  CONTINUE 

WRITE  (7,135)  THAN, (  NUMBS(  J  ),J=  1,50  ) 

135  FORMAT  ('  ',F8.2,'  +',5011,'+') 

140  CONTINUE 

WRITE  (7,125) 

WRITE  (7,120)  (  SLAN(  I  ),  1  =  1 ,5  ) 

WRITE  (7,115)  (SLVANd  >,1  =  1,5) 

GO  TO  25 
145  CONTINUE 
END 


non 


C********************  FKICT2 » FOR  W:#)*:#*^:*:*#*#****:*)!:*:^*^#**^*^**^*^* 


Dele  of  revision;  17-N0V-F.2 


PROGRAM  FKBET2 
PURPOSE 

To  produce  a  50  by  50  slowness- theta  dele  message 

USAGE 

RUN  FKDET 

Input  dele  is  reed  front  unit  11  or  12 
The  diagram  is  output  to  unit  17 

INPUT  PARAMETERS 

IBKNR  -  BlocTC  number  of  dataset 
NARRAY  -  Array  type  Cl  if  n-£  *  0  if  n-7  ) 

NREC  -  Number  of  records  (3  or  4  ) 

NSNO  -  Number  of  smoothings 

IG  -  Power  factor  for  detector  sharpening 

NOP  -  Number  of  date  points  C must  be  3  power  of  2) 

NREC  -  Missing  channel  < 0 » 1 > 2 » 3  *  4  *  5 * 6  or  7) 

YEAR  -  A  two  digit  integer- 
JULIAN  -  A  three  digit  integer  Julien  dsy 
DATE  -  A  two  digit  integer  date  of  month 
TINE  -  A  four  digit  integer 

SERIAL  -  A  four  digit  integer  C 5000  <  SERIAL  <  5099) 

INF  NR  -  A  four  digit  integer 
NONTH  -  A  three  letter  month  abbreviation 
THMIN  -  Minimum  value  of  theta  for  diagram 
THMAX  -  Maximum  value  of  theta  for  diagram 
SLMIN  -  Minimum  value  of  slowness  for  diagram 

SLMAX  -  Maximum  value  of  slowness  for  diagram 

EST  NR  -  Estimate  number  of  frequency  for  analysis 
DMIN  -  Minimum  detector  value  to  be  output 

DMAX  -  Maximum  detector  value  to  be  output 

REMARKS 

Provision  is  made  in  this  program  for  the  future  expansion  of 
the  n-6  array  to  four  channels.  When  this  is  done»  the  X  end  Y 
coordinates  of  the  new  station  should  be  inserted  before 
statement  7. 

LIBRARIES  REQUIRED 
ANTL IB » SY l F0RL IB 

METHOD 

A  beam-steer  state  detector  is  applied  to  the  spectral  matrix 
at  the  specified  frequency.  To  save  memory  space,  the  spectral 
matrix  is  determined  at  seven  freouencies  near  the  specified 
freouency.  These  are  smoothed!  then  all  but  the  freauency  of 
interest  are  discarded. 


COMMON  /DATPAS/  DAT AC  512*4  >*FXI< 512*4  >* NOP, MREC, NARRAY, IREC 
COMMON  /BETEK/  DETRC 50 , 50 ) , IDIREC * INULL 

COMMON  /SPEC/  SMATRC  256  ), TRACE C  256  )  »NREC , NHALF  *  NSM0  *  FN0P 
DIMENSION  HOC  50  ) ,  ARC  4  ) ,  AI C  4  >*SPMRC  9  ),SPNI<  9  ) 

DIMENSION  TEMPRC4  )*TEMPIC  4  )*X(  4  >,Y<4  )  *  SLANC  5  )  *  SLt'ANC  5  ) 
DIMENSION  SPMARC  4*4  IrSPMAIC  4*4  )*NUMBSC  50 ) 


EQUIVALENCE  < IHET< 1  )»SMATR( 1  )  ),<  AR<  1  >iSMATR< 51  )  ) 

EQUIVALENCE  <  Al<  1  )>SMATR(  55  )  )*(  TEMF'R<  i  ),SMA7F:<  59  )  ) 

EQUIVALENCE  < TEMP I <  1  ).SMATR<  63  )  )»( SLAN<  1  >.ShATR*67  )  ) 

EQUIVALENCE  <  SLVANv 1  ).SMATR< 72  )  ) 

EQUIVALENCE  <  SPMRC  1  )*SMATR<  150  )  ),<SPMI(  1  ).SMATR<  160  )  ) 

EQUIVALENCE  (  SPMAR<  1 . 1  ).SMATR<  170  )  >*<  SPMAI<  1 .  1  ),Si1ATR<  190  )  ) 

C . . . ♦ . 

C 

C  Program  ini ii el i zsli on  area 

C 

TYPE  1 

1  FORMAT  ('OEnter  IFKNR  * NARRAY *  NREC  *  NSHO » I G»  NOF"  ) 

ACCEPT  2*IBKNR*NARRAY.NREC,NSM0* ICiNOP 

2  FORMAT  <6110) 

IF  <  NOP  .EG .  0)  N0F’  =  512 
IF  < IQ  .EG.  0)  I G=1 
IF  <  NSMO  .EQ.  0)  NSM0=3 
IF  <  NREC  .EQ.  0)  NREC=4 
MREC=0 

IF  <  NREC  . EQ.  4)  GO  TO  4 
TYPE  3 

3  FORMAT  ('  Enter  MISSING  channel') 

ACCEPT  2.MREC 

MREC=MREC+ 1 

IF  (NARRAY  .EQ.  1)  MREC=MREC-4 

4  SINT= 1 . 

IF  < NARRAY. EQ. 1  )  81  NTs. 25 
X<  1  )=0 . 

Y<  1  )=0. 

IF  <  NARRAY. EQ. 1  )  GO  TO  5 
.  KREC=4 
IUNIT=11 
X<  2  )=-2 . 406 
Y<  2  )=5 . 658 
X<  3  )=5 . 459 
Y<  3  )=3 . 099 
X<  4  )=3 . 685 
Y<  4  )=-l  . 057 
GO  TO  6 

5  IUNIT=12 

X<  2  )=-0 . 008 
Y<  2  )=1 .126 
X<  3  )=0 . 946 
Y<  3  )=0 . 57? 

C  The  comment  flags  should  be  removed  from  these  statements*  snc! 

C  the  values  of  the  new  station  location  should  be  inserted*  when 

C  the  small  array  is  expanded  to  four  channels.  The  value  of  KF:EC 

C  should  be  changed  to  4. 

C  X<  4  >=0  ♦ 

C  Y<  4  )=0 . 

KREC=3 

C  The  following  statement  should  be  removed  when  the  new  station 

C  is  added  to  the  system. 

MREC=4 

6  NREC=4 
NHALF=N0F'/2 
FN0P=FL0AT < NOP  ) 

FZR0=1 ./<  SINT*FN0P  ) 

PI=3. 14159 


noon  oooo  oonr> 


RAH=PI/130. 

PAUSE  '  Insert  date  disk' 

READ  CIUNIT)  ( (  DAT A(  J  >  I  ) »  J=  1 »  NOP  )»!  =  !»  KREC  ) 


Set  of  message  header 

TYPE  7 

7  FORNAT  ('  Enter  YEAR  *  JUL I  AM »  DATE  .  T I  HE  *  SERIAL  *  I  NFMR '  ) 

ACCEPT  2  *  J  YEAR » JULIAN »  HIiATE  » MT IME  *  NRSER .  INFNF: 

TYPE  8 

8  FORMAT  ('  Enter  MONTH' ) 

ACCEPT  9  *  AMONTH 

9  FORMAT  ( A3  > 

10  format  < '(?eegg<?gg'eee(?(?g'G*aiG,e,C''eC',s,i?(?  \\_'./.'rr  ruebal  bv\_  ) 

11  FORMAT  ('HE  RUHHWEB  '  *314*'  D\\_ '  *  / »  '  ZNR  UUUU’JW. '  ,  /  » '  R'  .  13 , 1 4  . 

&  'Z  '  » A3  *  13  s '  \\_  '  »  / «  '  FM  MCKURHO  STATION  ANTARCTICAW.  '  ) 

12  FORMAT  ('TO  GEOPHYSICAL  INSTITUTE  FAIFiBANKS  AK//TELEX  MR'* 

&  '  35414//\\_'  »/.  '  ACCT  NS-WCAB\\_') 

13  FORMAT  (  'BT\\_'  ./.'  UNCLAS  INFRASOMICS  MR '  *  1 3  * ' - ' *  1 4  * ' \\ _ '  ) 

14  FORMAT  ('PASS  TO  HR  C  UILSONW.  '  *  /  ,  '  SUB  J  I  F-K  ANALYSISW.  '  ) 
PAUSE  '  Insert  message  disk' 


Transform  to  frequency  domain  and  determine  maximum  power 

CALL  SPECTR 
TMAX=-1  .E10 
BO  15  J=  1 » NHALF 

IF  (TMAX.GE.TRACE(J  ))  GO  TO  15 
TMAX=TRACE( J  ) 

FMAX=SNATR< J  ) 

HAXJ  =  .J 

15  CONTINUE 

TYPE  20 . TMAX  » FMAX » MAX J  *  NHALF 
20  FORMAT  < ' OMAXPOUER 1 ' , E15 . 3 » '  AT'.F10.4>'  HERTZ'. 

*  / * 5X» ' <  ESTIMATE' » 15 » '  OF'  .15,')') 


Set  up  range  of  slowness-theta  diagram 

25  CONTINUE 

BETMAX=-1  . 

TYPE  30 

30  FORMAT  ('OEnter  THMIN.THMAX  or  11  to  exit') 

READ  < 5»35.END=150 >  THMN.THMX 
35  FORMAT  (2F10.5) 

IF  ( ( THMN  .NE.  0.)  .OR.  ( THMX  .NE.  0.))  GO  TO  37 
THMN=0 . 

THMX=360 . 

37  THMN=THMN*RAB 
THMX=THMX*RAD 
HTH=(  THMX-THMN  )/50. 

TYPE  40 

40  FORMAT  ('  Enter  SLMI N . SLNAX '  ) 

READ  ( 5.35  )  SLMN.SLMX 

IF  (  ( SLMN  .NE.  0.)  .OR.  (SLMX  .NE.  0.))  GO  TO  42 
SLMN=0 . 

SLMX=5 . 

HS=< SLMX-SLMN  )/50. 


42 


o  o  o  nooo  onoo 


t 


44 


TYPE  44 

FORMAT  <'  Enter  EST  .  NR'  ) 
READ  ( 5 »  39  )  K 
39  FGRNAT( 13  > 

IF  <K  ,EQ.  0)  K=MAX>J 
FREG=FZF:0*FL0AT<  K-l  ) 
0MEG=T0P  I  $:FF:EQ 


Calculate  erectr  el  metric 


45 


46 

47 


48 

49 


KN=K-4 

KP=K+4 

IF  (KN.LE.O)  KH= 1 

IF  < KP.GT.NHALF  )  KF'=NHALF 

KN1=KN+ 1 

KF'1  =  KP-1 

IF  <  K.LT .KM1  )  K  =  KN1 
IF  (K.GT.KPl)  K=KP1 
KS=KP-KH+1 
KSl=KF'l— KN1  +  1 
TNAX=0. 

HO  49  1  =  1 .  NREC 

IF  (I  .EQ.  MREC  )  GO  TO  49 
DO  48  J= 1 i NREC 

IF  <  J  .EQ.  NREC  )  GO  TO  48 
DO  45  M=1 .KS 
KT=KM+M-1 

SPHR<  M  )=DAT A(  KT  ,  I  )*ZlATA<  KT » J  H  FXI(  KT  .  I  HFXK  KT  » J  > 
SPMK  N  )=FXI<  KT  .  I  )«BATA(  KT  .J  )-DATA<  KT  » I  )$FXI(  KT  «J  ) 
CONTINUE 

DO  47  ISM0=1 »NSMQ 
DO  46  M=2  *  KS 1 

SPHR<  M  >= ,5*t  SF’HR(  N  H-.5*>:  SPMRC  H-l  >+SPMR<  M  +  l  )  )  ) 
SPNKH  )=.5*<  SF'H  1  <  N  >4.54:-:  SPMI<  N-l  HSPNK  M41  )  )  ) 

CONTINUE 
CONTINUE 
M=K-KM1 +2 

SPNAR(  I  *  J  )=SF'NR<  M  ) 

SPMAIC  1 1 J  )=SF'NI(  N  ) 

CONTINUE 

TNAX=TMAX+SPNAR< 1 . 1  > 

CONTINUE 


Calculate  detector  level  for  each  value  of  slowness  end  the f e 

DO  85  I  TH=  1  ?  50 

THETA=THNN+FLOAT<  ITH-1  >*I(TH 
DO  80  ISL= 1 »50 

SLOW=SLMN+FLOAT< ISL-1  >*IiS 

Calculate  state  vector 

SVS=SLOW*SIN<  THETA  ) 

SVC=S10U*C0S<  THETA  ) 

AR<  1  )=1  . 

Al<  1  )=0 . 

DO  50  1=2. NREC 

IF  < I  . EQ .  NREC  )  GO  TO  50 


» 


o  o  n  n  o  o  o 


TAU=(  X-:  I  )-XC  1  )  )*SVS+(  Y(  I  )-Y(  1  )  )*SVC 
AR(  I  )=COS(  OMEG*TAU  ) 

AI( I  )=SIN< OMEG*TAU  ) 

50  CONTINUE 

AHAG=0. 

HO  55  1=1 .NREC 

IF  (I  .EG.  MREC  )  GO  TO  55 
AMAG=AMAG+ AR(  I  >**:21AI(  I  )tt 2 
55  CONTINUE 

AMAG=SQRT ( AMAG  ) 

HO  60  1  =  1 » NREC 

IF  (  I  .EG.  MREC  )  GO  TO  60 
AR(  I  )=AR(  I  )/ AMAG 
AI(  I  )=AI  ( I  )/AMAG 
TEMPR(  I  )=0 . 

TEMPI (  I  )=0  . 

60  CONTINUE 

Iapress  stele  vector  on  spectre!  matrix 

OETR< ITH, ISL )=0. 

HO  70  1=1 »NREC 

IF  (I  .EG.  MREC  )  GO  TO  70 
no  65  J  =  1  *  NREC 

IF  (J  .EG.  MREC)  GO  TO  65 

TEMPR<  I  )=TEMPR<  I  HSPMAR(  I,  J  )*ARt  J  >-SPMAI(  I » J  )*AI(  J  > 
TENPK  I  )=TEMPI(  I  )+SPMAR<  I .  J  >*AI(  J  )+SPMAI<  I  *  J  )*AR(  J  ) 
CONTINUE 
CONTINUE 
HO  75  J  =  1 *  NREC 

IF  ( J  .EG.  MREC  )  GO  TO  75 
H=<  TEMPR(  J  )*AK(  J  )+TENPI(  J  >*AI<  J  )  )/TMAX 
HETR<  ITH.  ISL  )=DETR<  ITH.  ISL  H(  ptflG  ) 

CONTINUE 

IF  <  IlETR<  ITH.  ISL  ) . GT  , BETMAX  )  OETMAX=BETR(  ITHt ISL > 

CONTINUE 
CONTINUE 


65 

70 


75 

80 

85 


SI ouness-thets  disSrsm  output  sree 

90  CONTINUE 

TYPE  95 , KETMAX 
TYPE  96 

ACCEPT  35 »  PMI M»  BMAX 

IF  ( UMAX ♦ NE . 0 .  )  GO  TO  100 

95  FORMAT  (15X,'  ARRAY  MAX l ' , F7 . 3 » /  ) 

96  FORMAT  < '  Enter  OMI N» UMAX'  ) 

BNAX=HETMAX 

0MIN=HETMAX*.707 

100  HRANG=IiMAX-nMIN 
WRITE  < 17,10) 

WRITE  (17,11)  NRSER » JULIAN, MTIME, MO ATE » MTIME »  AMONTH, J YEAR 
WRITE  (17,12) 

WRITE  (17,13)  .JYEAR,  INFNR 
WRITE  (  17,14  ) 

WRITE  (  17,105  )  IBKNRvK 
WRITE  (  17,103 )  UMAX , DM IN 

103  FORMAT  ('ARRAY  MAX:',F7.3»'  ZERO  CONTOUR  ATI ' ,F7 .3,'  \\_'  ) 
105  FORMAT  <  '  F-K  OETECTION  AT  PLOCK',15,'  FREQ  ESTIMATE' *  13 »' \\_ '  ) 


SLVAN<  1  >=99999.9? 

PO  110  1=1.5 

SLAM I )=slmn+float< i-i >*us*io. 

IF  ( SLAW I  KEO.O.  )  GO  TO  110 
SLVAN<  I  )=1000./SLAN<  I  ) 

110  CONTINUE 

URITE  <17,115)  <  SLVAN<  I  >,  1  =  1 ,5  ) 

115  FORMAT  <  3X »  5F 1 0 . 2 »  '  N/SW-M 
URITE  <17,120)  <  SLAN< I  ), 1  =  1 , 5  ) 

120  FORMAT  < 2X,5F10.3, ' \\_'  ) 

WRITE  <  17,125  ) 

125  FORMAT  <  T9 , '  ! '  ,  T19 , '  ! '  ,  T29,  '  ! '  ,  T3? ,  '  ! '  ,  T49,  '  !  \\_  ) 

PO  140  1=1,50 

THAN=<  1-1  )*DTH/RAD+THMN/RAB 
PO  130  .1=1,50 

IIl=IFIX<  9.9*<  HETR<  I ,  J  )-PMIN  )/IiRANG  ) 

IF  <  <  IP.LE.O  ).0R.<  III.GE.  10  ) )  in=o 
NUMBS<  .3  )=IH 
130  CONTINUE 

WRITE  <17,135)  THAN,<  NUMBS<  J  ),.J  =  1 ,50  ) 

135  FORMAT  <F6.2,'  -' » 501 1 , ' -\\_'  ) 

140  CONTINUE 

WRITE  <  17,125  ) 

WRITE  <17,120)  <SLAN<  I  >,1  =  1,5) 

URITE  <17,115)  (  SLUAtK  I  ),  1  =  1 ,5  ) 

WRITE  <  17,145  ) 

145  FORMAT  <  '  REGARDS,  KAY\\_'  ,/,'t’T\\ _ NNNN'  ,  / , 

&  '  iiiiiiiiiimiDiiiimieeeGeeeeeee&geeseeet?'  ) 

MTIME=MTIME+10 
NRSER=NRSER+ 1 
INFNR=INFNR+1 
GO  TO  25 
150  CALL  EXIT 
END 


TITLE  MODEM  CONTROL 


A  routine  to  move  a  blocK  of  ASCII  characters  from  a  disk  tiler 
convert  them  to  5-leveJ.  radioteletyre  code*  and  punch  them  onto 
teletype  tare. 

Several  ASCII  characters  have  been  assigned  to  5- level  carriage 
control  character  codes.  These  aret 
e  Null 
C  Space 
3  Letters 
1  Fisures 
\  Carriage  Return 
Line  Feed 

The  program  deletes  ell  ASCII  control  characters  end  lower  case 
characters . 


. MCALL 

.CSIGEN* .READW* 

.EXIT,  .PRINT 

.MCALL 

. WRITW »  .CLOSE* . 

SRESET 

modem: 

.CSIGEN 

♦DSPACE.4DEXT 

;get  string  from  tt: 

CLR 

FLAG 

;INIT  CHARACTER  MODE 

CLR 

FLKCNT 

{ I N I T  INPUT  BLOCK  COUNT 

CLR 

OUTCNT 

ilNIT  OUTPUT  BLOCK  COUNT 

10$ : 

.READW 

*BBLK.#3**BUFF, 

♦256. ,BLKCNT 

BCC 

11$ 

{BRANCH  IF  NO  ERROR 

» 

f 

* 

DETERMINE  ERROR 

f 

TSTR 

P*52 

;eof? 

BEQ 

80$ 

(YES  -  BRANCH 

.PRINT 

.EXIT 

♦INERR 

{INPUT  ERROR  MESSAGE 

» 

9 

CONVERT 

ASCII  TO  5-LEVEL 

f 

n$: 

MOV 

FLAG*R3 

{GET  CHARACTER  MODE 

MOV 

♦BUFF  *  R4 

{GET  ADDRESS  OF  INPUT  BUFFER 

MOV 

♦OUTBUF *R5 

{GET  ADDRESS  OF  OUTPUT  BUFFER 

15$: 

CLR 

<  R5  )+ 

{CLEAR  OUTPUT  BUFFER 

CMP 

R5* ♦TABLE 

{DONE? 

BMI 

15$ 

{NO,  CONTINUE 

MOV 

♦OUTBUF  »R5 

{GET  ADDRESS  OF  OUTPUT  BUFFER 

12$: 

MOV 

♦CHART, R1 

{GET  ADDRESS  OF  ASCII  TABLE 

DEC 

R1 

{INITIALIZE  ASCII  TABLE  COUNTER 

MOV 

♦TABLE, R2 

{GET  ADDRESS  OF  5-LEVEL  TABLE 

DEC 

R2 

{INITIALIZE  5-LEVEL  TABLE  COUNTER 

MOVB 

(?R4  *R0 

{GET  CHARACTER 

CMPB 

R0  *  #40 

{CHECK  IF  SPACE 

BNE 

13$ 

{BRANCH  IF  NO 

MOVB 

♦  133, RO 

{REPLACE  WITH  LEFT  BRACKET 

13$: 

CMPB 

♦137, RO 

{CHECK  IF  LOWER  CASE 

BMI 

19$ 

{BRANCH  IF  YES 

CMPB 

RO  *  #40 

{CHECK  IF  CONTROL  CHARACTER 

BMI 

19$ 

{BRANCH  IF  YES 

CMPB 

♦132, RO 

(CHECK  IF  CARRIAGE  CONTROL  CHARACI E 1 

BMI 

16$ 

{BRANCH  IF  YES 

TSTB 

R3 

{CHECK  IF  IN  LETTERS  MODE 

BEG 

14$ 

{BRANCH  IF  YES 

CNF'B 

R'0,4101 

{CHECK  IF  CHARACTER  IS  A  LETTER 

BMI 

18$ 

{BRANCH  IF  NO 

NOVB 

♦37  *@R5 

{MOVE  LETTERS  TO  OUTPUT  BUFFER 

INC 

R5 

{INCREMENT  OUTPUT  BUFFER 

CLR 

R3 

{SET  LETTERS  MODE 

BR 

18$ 

{GO  TO  LOOKUP  TABLE 

♦  * 

r-» 

CMPB 

♦  77  *  RO 

{CHECK  IF  CHARACTER  IS  A  FIGURE 

BMI 

18$ 

{BRANCH  IF  NO 

NOVB 

♦33  ,  (?R5 

{MOVE  FIGURES  TO  OUTPUT  BUFFER 

INC 

R5 

{INCREMENT  OUTPUT  BUFFER 

MOV 

♦  1 » R3 

{SET  FIGURES  MODE 

BR 

18$ 

{GO  TO  LOOKUP  TABLE 

16$ : 

CNF'B 

♦  136,  RO 

{CHECK  IF  CHARACTER  IS  A  FIGURES  SYMBOL 

BNE 

17$ 

{BRANCH  IF  NO 

MOV 

♦  1,R3 

{SET  FIGURES  MODE 

BR 

18$ 

{GO  TO  LOOKUP  TABLE 

17$: 

CMPB 

♦135.R0 

{CHECK  IF  CHARACTER  IS  A  LETTERS  SYMBOL 

BNE 

18$ 

{BRANCH  IF  NO 

CLF< 

R3 

{SET  LETTERS  MODE 

♦♦ 

CD 

n 

INC 

R1 

{INCREMENT  ASCII  TABLE  POINTER 

INC 

R2 

{INCREMENT  5-LEVEL  TABLE  POINTER 

CMPB 

ROv@Rl 

{CHECK  FOR  MATCH 

BNE 

18$ 

{NO,  TRY  AGAIN 

MOVE 

0R2 . PR5 

{YES,  MOVE  5-LEVEL  VALUE  TO  OUTPUT  BL1FEE 

INC 

R5 

{INCREMENT  OUTPUT  BUFFER 

i?$: 

INC 

R4 

{INCREMENT  INPUT  BUFFER 

CMP 

R4 » ♦OUTBUF 

{CHECK  IF  LAST  CHARACTER 

BMI 

12$ 

{NO,  GET  ANOTHER  CHARACTER 

MOV 

R3»  FLAG 

{SAVE  CHARACTER  MODE 

SUB 

♦OUTBUF, R5 

{GET  OUTPUT  CHARACTER  COUNTER 

BR 

20$ 

{DONE 

* 

f 

* 

OUTPUT 

BLOCK 

f 

20$: 

MOV 

♦OUTBUF, R2 

CLR 

R1 

30$: 

. WRITW 

♦IfBLK ,  40 , R2  » 41 

,  OUTCNT 

BCC 

40$ 

.PRINT 

♦OUTERR 

.EXIT 

40$: 

INC 

OUTCNT 

{POINT  TO  NEXT  OUTPUT  BLOCK 

Aim 

♦  2 ,  R2 

{INCREMENT  OUTPUT  BUFFER  ADDRESS 

ABB 

♦  2 ,  R1 

{INCREMENT  OUTPUT  CHARACTER  COUNTER 

CMP 

R1  ,R5 

{CHECK  FOR  LAST  OUTPUT  CHARACTER 

BMI 

30$ 

{NOT  HONE,  GET  MORE 

INC 

BLKCNT 

{POINT  TO  NEXT  INPUT  BLOCK 

JMP 

10$ 

{DO  NEXT  INPUT  BLOCK 

80$: 

•URITW 

♦DBLK*40,4CTLZ 

,♦10,40 

.CLOSE 

♦0 

.CLOSE 

♦  3 

.SRESET 

JMP 

MODEM 

flag: 

.WORD 

0 

ctlz: 

.BYTE 

0,0, 0,0, 0,0,0, 0,0, 0,0, 0,0, 0,0,0 

dext: 

.WORD 

0,0,0, 0 

dblk: 

.  BLKU 

5 

blkcnt: 

OUTCNTt 

buff: 

outbuf: 

f  table: 

chart: 

inerr: 

outerr: 

t 

DSPACE= 

♦ 


r 


r 


f 


» 


i 


i 


i 


.  WORD  0 
♦WORD  0 
.BLKW  256. 

.  BLKU  500. 

.ASCII  /ItMGTIEZKOReeLCNIUWSAJPUGFXNteeC-Y/ 
.ASCII  /eCYNIAHZTFK0R\LXVWJEPGtS3UQHH_CB/ 
.ASCII  »  )*+*-. /i/0123456789:  i<=>?/ 

.ASCII  /8ABCDEFGHI.JKLMN0PQRSTUVWXY2C  \  _/ 

. ASCIZ  /INPUT  READ  FAILED./ 

. ASCIZ  /OUTPUT  READ  FAILED./ 

.EVEN 

.END  MODEM 


i 


i 


c*************** 

c 


r.  POLFIL  .FOR  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 

revision?  19-Jui-82 


PROGRAM  POLFIL 
PURPOSE 

To  filter  3  3  or 
of  the  freouenc* 
transform  of  the 


4  chsnnel  time  series  through  the  explication 
dependent  degree  of  polarization  to  the 
time  series* 


USAGE 

RUM 

The 

The 


POLFIL 

dataset  must  be  stored  in  FTN11.DAT 
filtered  dataset  is  returned  to  FTN21.BAT 


INPUT  PARAMETERS 


window 


NREC  -  Number  of  dimensions 

NSMO  -  Number  of  smoothings 

IG  -  Power  factor  for  filter  sharpening 

NOP  -  Data  points  in  window  <must  be  a  power  of  2 ) 

NTOT  -  Total  number  of  data  points 

OLAF'  -  Overlap  of  window  segments  (  0*<0LAR<1 .  ) 

REMARKS 

None 

LIBRARIES  REQUIRED 
ANTLIB*  SY?FORLIB 

METHOD. 

The  degree  of  polarizationf  F'»  is  derived  from  the  spectral 
matrix,  S*  for  each  frequency  according  to  the  formula  given 
by  Samson?  P  =  (  N<  TR<  S**2  )  >-(  TR<  S  >**2  )  /  ( <  N-1>*C  TR<  S  )  >**2  ) . 
In  applications  where  events  occur  simultaneously  on  all  of 
the  dimensions*  a  long  time  series  can  be  filtered  by  using  a 
sliding  window  method.  In  applications  where  the  time  delay 
between  the  dimensions  is  of  significance*  the  sliding  window 
introduces  phase  distortion. 

COMMON  /DATPAS/  DAT A( 512,4 >*FXI( 512*4 >»N0P, IG»NARRAY* IREC 

COMMON  /BETEK/  BUMMY(256*4) 

COMMON  /SPEC/  POL( 254  )»TRACE( 256 >* NREC, NHALF* NSMO* FNOP 

DIMENSION  ALLDAT< 1000,4  ) 


Program  initialization  area 
TYPE  5 

FORMAT  ('  ENTER  NREC,NSM0, IG*NOP,NTOT*OLAP'  ) 
ACCEPT  10  * NREC* NSMO, IG* NOP, NTOT 
FORMAT  (5110) 

IF  (NREC  .EQ.  0)  NREC=4 
IF  (NSMO  .EQ.  0)  NSM0=3 
IF  ( IG  .EQ.  0 )  IC=1 
IF  (NOP  .EQ.  0)  N0P=512 
IF  (NTOT  .EQ.  0)  NT0T=512 
0LAP=0.8 
NHALF=N0P/2 
NHALF 1=NHALF+1 


I 


FNOP=FLOAT<  NOP  ) 

FN0PSQ=FN0P**2 
NREC1=NREC-1 
FREC=FLOAT<  NREC  ) 

FRECl=FLOAT<  NREC1  ) 

I UNIT  =  1 1 

C.  . . 

c 

C  Read  in^ui  date  and  set  up  sliding  window 

C 

READ  ( I UNIT  )  << ALLDATC J, IREC  ).J=1, NTOT >»IREC=1, NREC) 
NSTART=0 
111  CONTINUE 

DO  14  IREC=1 » NREC 
DO  12  J  =  1 »NOP 
J  J=.J+NST  ART 

IF  ( JJ  .GT.  NTOT  }  GO  TO  11 
DATA( J » IREC  )=ALLDAT< JJ. IREC  ) 

GO  TO  12 

11  PATA<  J » IREC  >=0  . 

12  CONTINUE 

IF  <  NSTART  .EQ.  0 >  GO  TO  14 
DO  13  J=1 .NHALF 

JJ=J+NHALF+NSTART 

IF  <JJ  ,  GT .  NTOT)  GO  TO  13 

ALL  DAT  <  JJ  .IREC  )=DUHNY<  4, IREC  > 

13  CONTINUE 

14  CONTINUE 

C . 

c 

C  Transform  to  freouenev  domain 

C 

DO  20. IREC=1 .NREC 
DO  15. 1=1. NOP 

FXI< I. IREC  )=0 • 

15  CONTINUE 
CALL  DC 
CALL  FFT(  1  ) 

20  CONTINUE 

C . . . . . 

c 

C  Form  Trace  terms  in  polarization 

C 

DO  25, 1=1, NHALF 
PUMMYt  1.3  )=0. 

DUHMY< 1,4  )=0. 

TRACE( I  )=0 « 

25  CONTINUE 

DO  45  IREC=1 .NREC 
DO  30  1=1, NHALF 

DUHMY<  1 , 1  )=DATA<  I ,  IREC  )**2+FXI<  I » IREC  >**2 
30  CONTINUE 

DO  35  1=1 ,NSHO 

CALL  SHOOTH(  NHALF. 1 ) 

35  CONTINUE 

DO  40  1=1, NHALF 

DUNNY(  1 , 3  )=DUNMY<  1 , 3  HIiUHMYt  I ,  l  ) 

DUMNY( I»4  )=BUHNY< 1,4  )+BUNNY<I,l )**2 
40  CONTINUE 

45  CONTINUE 


oooo  noon  onno 


C  Form  cross  terms  of  spectral  matrix 

C 

HO  70  J=1 . NREC1 
JK= J+l 

HO  65  K=JK. NREC 
HO  50  1=1. NHALF 

HUMMY< I. 1  >=HATA<  I  f  J  >*IlATA<  1  .K  >+FXI<  If  J  >#FXI<  IfK) 
HUMMY<  I  f  2  )=FXI<  If  J  )*HATA<  IfK)-HATA(  I.J  >*FX1<  IfK) 

50  CONTINUE 

HO  55  1=1 f NSHO 

CALL  SH00TH< NHALF. 2 > 

55  CONTINUE 

DO  60  1=1 f NHALF 

TRACE<  I  )=TRACE<  I  )+2  .  *<  OUMMYC  1 1 1  )**2+DUMMY<  1 1 2  >**2  ) 
60  CONTINUE 

65  CONTINUE 

70  CONTINUE 


Compute  degree  of  polarization 
HO  75  1=1 f NHALF 

PNUN=FREC*(UUMNY< 1.4  >+TRACE(  I  )  >-UUHHY< 1.3 )**2 
PHEN=FRECl*nUNHY< 1 .3  )**2 
P0L(  I  )=<  PNUN/FHEN  >**IG 
75  CONTINUE 


Impress  degree  of  polarization  on  transforms 

P0L<  1  )=0 « 

00  85  IREC=1.NREC 
HO  80  1=1. NHALF 

HAT A(  I .  IREC  )=HATA<  I  .  IREC  >*P0L<  I  ) 

FXI< I.IREC  )=FXI< I . IREC >*P0LC I  ) 

IF  ( I  . EQ ♦  1  )  GO  TO  80 
J=NOP-I+2 

HATAC  J.  IREC  )=I«ATA<J»  IREC  >*P0L<  I  ) 
FXKJ.IREC  )=FXI<  J  » IREC  >*P0L<  I  ) 

80  CONTINUE 

DATA<NHALF1. IREC  )=HAT A( NHALF . I REC  ) 
FXKNHALF1.  IREC  >=0. 

85  CONTINUE 


Return  to  time  domain  and  set  up  for  next  window  or  end 


87 

90 


no  90  IREC=1 . NREC 
HO  87  4=1 .NOP 

nATA< 4 » IREC )=HATA< J. IREC  >/FNOP 
FXI(  J. IREC  )=FXI< J > IREC  )/FN0P 
CONTINUE 
CALL  FFT ( -1 ) 

CONTINUE 

NZR0=IFIX< FN0P*< l.-0LAP>/2.  >+l 
NSTRT=NSTART 

NSTART=NSTART  +  IFIX<  FN0P*0LAP ) 
NENH=NST  ART +N0P 


ooooooooooo  non 


91 


92 

95 


NCOK=NHALF 

IF  (NEMIi  .GT,  NTOT  )  NCOM=NOP 
DO  95  IREC=1 fNREC 
HO  91  J=1 » NZRO  ' 

J J=NOP-J+ 1 
DATA'.  JJf IREC )=0. 

IF  ( NSTRT  .LT.  NOP)  GO  TO  91 
DATAC  J  *  IREC  )=0  % 

CONTINUE 
PO  92  J  =  1 »  NCOM 
JJ=J+NSTRT 

IF  <  JJ  .GT,  NTOT >  GO  TO  92 
ALLDAT(  JJf IREC  )=DATA<  J  f  IREC  ) 

IF  <  NCOM  .EG.  NOP  )  GO  TO  92 
J J J= J+NHALF 

.  DUMMY< Jf IREC )=DATA<JJJf IREC  ) 

CONTINUE 

CONTINUE 

IF  (NENH  .LT.  NTOT)  GO  TO  111 
IUNIT=IUNIT+10 

WRITEC I UNIT  )  <( ALLHAT( J»IREC  )i J=1 » NTOT )» IREC=1 » NREC  ) 

CALL  EXIT 

END 


SUBROUT  I NE  SMOOTH<  NOF . NREC  ) 

PURPOSE 

To  perform  s  three-point  smoothing 
USAGE 

CALL  SMOOTH(  NOP* NREC ) 

INPUT  PARAMETERS 

NOP  -  Number  of  points  in  dele  string  to  bo  smoothed 

NREC  -  Number  of  data  strings  to  be  smoothed 

COMMON  /DETEK/  DUMMY(256f4) 

NMl=NOP-l 
DO  20  K=1 *NREC 
DO  10  I=2t NM1 

DUMMY<  I  »K  >=<  DUMMY  <  IfK  )+<  DUMMY  <  1-1  f  K  )+ DUMMY  <  HI  »K)  )/2.  )/2. 
10  CONTINUE 

DUMMY<  1  f  K  )=<  DUMMY <  1 1 K  )+DUMMY (  2 » K  >  )/2 . 

DUMMY(  NOPfK  )=<  I«UMMY<  NOPrKHDUMMYC  NM1  .  K  )  >/2. 

20  CONTINUE 
RETURN 
END 


o  o  o  n 


C**##****#*#**#* 

c 

C  Date  of  f 


c  PUREFL  .FOR  **%*XX*%X*******t*****t**X*****X**X.t*Xt.t%* 
revision!  18-Jul-82 


PROGRAM  FUREFL 


PURPOSE 

To  filter  s  3  or 
of  the  freouency 
transform  of  the 


4  channel  time  series  through  the  application 
dependent  degree  of  polarization  to  the 
time  series. 


USAGE 

RUN 

The 

The 


PUREFL 

dataset 


must 


stored 


FTN11.DAT 


FTN12.DAT 


filtered  dataset 


returned  to  FTN21 


FTN22.DAT 


INPUT  PARAMETERS 

IBKNR  -  BlocK  number  of  dataset 
NARRAY  -  Arrau  type  <1  if  n~6i  0  if  n-7 ) 

NREC  -  Number  of  records  (3  or  4 ) 

NSMO  -  Number  of  smoothings 

IG  -  Power  factor  for  filter  sharpening 

NOP  -  Number  of  data  points  <must  be  a  power  of 

MREC  ~  Missing  channel  < 0» 1 *2, 3*4*5, 6  or  7  ) 


sharpen ing 


REMARKS 

Provision  is  made  in  this  program  for  the  future  expansion  of 
the  n -6  array  to  four  channels.  When  this  is  done*  the  two 
statements  indicated  below  should  be  removed. 

LIBRARIES  REQUIRED 
ANTLIB  *  SY  *,  FORLIB 

METHOD 

The  degree  of  polarization*  P*  is  derived  from  the  spectral 
matrix*  S*  for  each  freouency  according  to  the  formula  given 
by  Samson:  P  =  <  N<  TR<  S*#2  )  )-<  TR<  S  >#*2  )  /  <  <  N-l  >*(  TR<  S  )  >**2  ) . 
In  applications  where  events  occur  simul taneouslv  on  all  of 
the  dimensions*  a  long  time  series  can  be  filtered  by  using  a 
sliding  window  method.  In  applications  where  the  time  delay 
between  the  dimensions  is  of  significance*  the  sliding  window 
introduces  phase  distortion. 

COMMON  /DATPAS/  BATA' 5 1 2  *  4  )  * FXI< 512 » 4  )* NOP  * IG*NARRAY * IREC 
COMMON  /BETEK/  BETR< 50  *  50 ) * IDIREC * INULL 

COMMON  /SPEC/  P0L<  256  1, TRACE*  256  )*NREC*NHALF  »NSM0»FN0P 
DIMENSION  DUMMY*  300 ,4 ) 

EQUIVALENCE  * DETR( 1*1  )*DUMMY* 1*1 )) 


Program  initialization  area 
TYPE  5 

5  FORMAT  *'  ENTER  IBKNR, NARRAY »NREC. NSMO* IG»N0P'  ) 
•  ACCEPT  10* IBKNR, NARRAY  * NREC* NSMO* IG*N0P 

10  FORMAT  (6110) 

IF  <  NOP  .EG.  0)  N0P=512 
IF  <  NSMO  .EG.  0)  NSM0=3 
IF  *  IG  .EG.  0)  IG=1 


I 


o  o n  n  non 


» 


I 


» 


t 


IF  (NREC  .EG.  0)  NREC=4 
NREC=0 

IF  ( NREC  .EQ.  4  )  GO  TO  13 
TYPE  12 

12  FORMAT  ('  ENTER  HISSING  CHANNEL') 

ACCEPT  10. NREC 

TYPE  95,IBNNR»IG»NREC 
NREC=MREC+1 

IF  (  NARRAY  .EG.  1)  HREC=MREC-4 

NREC=4 

GO  TO  14 

13  TYPE  96,IBKNR,1G 

14  KREC=4 

C  The  following  two  statements  should  be  removed  when  the  n-/> 

C  array  is  expanded  to  four  channels 

IF  (NARRAY  .EQ.  1)  KREC=3 
IF  (NARRAY  .EG.  1)  HREC=4 
NHALF=N0P/2 
NHALF 1=NHALF+1 
FNOP=FLOAT(  NOP  ) 

FNOPSQ=FNOP**2 
NREC1=NREC-1 
FREC=FLOAT( NREC  ) 

FREC1=FL0AT( NRECl  ) 

IUNIT=1 1 

IF  (NARRAY  .EG.  1)  IUN1T=12 

READ  ( IUNIT  )  ( <  DATA<  J  ,  IREC  ) » J  =  1 ,NDP  > » IREC= 1 , KREC  ) 


Transform  to  freouencw  domain 
IBIREC=1 

BO  20,IREC=1,NREC 

IF  (IREC  .EG.  HREC  )  GO  TO  20 
DO  15, 1=1. NOP 

FXI(  I, IREC  )=0. 

15  CONTINUE 

CALL  DC 
CALL  FFT 
20  CONTINUE 


Form  Trace  terms  in  polarization 


IDIREC=NHALF 

INULL=1 

DO  25, 1=1. NHALF 
DUMMYC  1,3  )=0. 

BUNNY<  1,4  )=0 . 

»  TRACE( 1  )=0 , 

25  CONTINUE 

DO  43  IREC=1 ,NREC 

IF  (IREC  .EG.  HREC)  GO  TO  45 
DO  30  1=1, NHALF 

DUHMY< 1 , 1  )=DATA< I , IREC  >**2+FXI(  I , IREC  )**2 
1  30  CONTINUE 

DO  35  1=1 ,NSM0 
CALL  SMOOT 
35  CONTINUE 

DO  40  1=1, NHALF 


I 


I 

40 
45 
C  «  •  »  « 

c 

c 

I  C 


V 


50 

t 

55 

60 

65 

*  70 
C  ♦  ♦  •  * 

c 

c 

c 

* 


75 
C  ♦  •  *  • 
c 

♦  c 

c 


» 


80 


I 


85 


C 

C 

C 

C 


i  ■MMWW— — — — 1 — 

PUNMY(  I , 3  )=PUNNY<  I * 3  )+PUMHY<  1*1) 
PUHMY<  1*4  )=PUHNY<  1*4  )+PUMNY(  I  *  1  )** 2 
CONTINUE 
CONTINUE 


Form  cross  terms  of  spectral  matrix 
INULL=2 

DO  70  J=1 .NREC1 

IF  (  J  .EQ.  NREC  )  GO  TO  70 
•JK=.J41 

no  65  K=JK  *  NREC 

IF  <  K  .EQ.  NREC)  GO  TO  65 
PO  50  1=1 *NHALF 

PUMMY<  1,1  )=PATA<  I,  J  )*IiATA<  I  ,K  )+FXI(  I»J  )*FXI(  I  * K  )  * 
PUMHY<  1,2  )=FXI<  I,  J  )*PATA<  I  *K  )-QATA<  I  *  J  >*FXI(  I  *  K  ) 
CONTINUE 
PO  55  1=1 *NSNO 
CALL  SNOOT 
CONTINUE 
PO  60  1=1 *NHALF 

TRACE(  I  )=TRACE<  I  )42  .  *(  PUMMY(  I  *  1  >**24PUNHY(  I  *  2  )**2  ) 
CONTINUE 
CONTINUE 
CONTINUE 


Compute  degree  of  polarisation 
PO  75  1=1 *NHALF 

FNUrt=FREC#<  PUHHY< 1*4  )4TRACE<  I  )>-PUNNY(  1,3  )**2 
Pr(EN=FRECl*DU«NY<  1*3  )#*2 
POL<  I  )=<  PNUN/PIiEN  >**IG 
CONTINUE 


Impress  degree  of  polarization  on  transforms 

P0L<  1  )=0. 

PO  85  IREC= 1 »NREC 

IF  (  IREC  .EQ.  HREC)  GO  TO  85 
PO  80  1=1 ,NHALF 

PAT A< I  * IREC  >=PATA< I » IREC  )*POL< I  ) 

FXI< I* IREC  )  rxi< I, IREC  )*POL< I  > 

IF  <  I  .EQ.  I  )  GO  TO  80 
J=NOP-I42 

PAT A<  J* IREC )=PATA<  J , IREC  )*POL< I  ) 

FXI<  J  * IREC  )=FXI<  J  * IREC  )#POL< I  ) 

CONTINUE 

PATA(NHALF1»IREC  )=PATA< NHALF  » IREC  ) 

FXI< NHALF 1 , IREC  )=0. 

CONTINUE 


Return  to  time  domain 

IPIREC=-1 

PO  90  IREC=1 ,NREC 

IF  (IREC  .EQ.  NREC)  GO  TO  90 


i 

) 


I 


CALL  FFT 

»  90  CONTINUE 

IUNIT=IUNIT410 

WRITE(  IUNIT  )  ( ( DATA< J.IREC). J=1 ,NOP  )» IREC=1 »KREC  ) 

95  FORMAT  ('  PUREFILTER  BLOCK  *'.I5»'  IG='»I2»'  CHANNEL'. 

&  12.'  MISSING'  ) 

96  FORMAT  ('  PUREFILTER  BLOCK  *',I5.'  IG=',12> 

t  CALL  EXIT 

END 


t 


i 


* 


> 


» 


» 


» 


I 


» 


u  o  a  u  u 


C****** ********:***  RECGET  .  FOR  * *:*:***:**:*: *** ***** *********** **** ****** 

C 

C  Date  of  revision l  i2-Ms-y-82 

C 

PROGRAM  RECGET 
C 

C  PURPOSE 

C  To  extract  a  recordfile  front  a  dataset 

C 

C  USAGE 

C  RUN  RECGET 

C 

C  INPUT  PARAMETERS 

C  IREC  -  Record  to  be  extracted  <1,2,3  or  4  ) 

C  INFILE  -  Logical  unit  of  dataset 

C  OUTFIL  -  Logical  unit  of  recordfile 

C 

C  REMARKS 

None 

LI  PR ARIES  REQUIRED 
SYJFORLIB 

METHOD 

C  The  dataset  is  read*  and  the  record  is  extracted  and  written 

C 

DIMENSION  DATA-:  512*4) 

INTEGERS  OUTFIL 
TYPE  10 

10  FORMAT!  '  ENTER  IREC , INFILE. OUTFIL'  ) 

ACCEPT  20, IREC, INFILE. OUTFIL 
20  FORMAT!  315) 

READ  ! INF ILE  )  ! ! DATA!  J , I ) , 0= 1 , 51 2 > . 1  =  1 , IREC  ) 

WRITE  !  OUTFIL)  !  DATA!  J  ,  IRED  ),J=1 ,512  > 

CALL  EXIT 
END 


non 


C********************  SPCTRM .  FOR  XtXXXXtX***tXt*X*tXXXt**t**tttt 

Date  of  revision?  20-Aug-82 


PROGRAM  SPEKT4 
PURPOSE 

To  perform  spectral  analysis  of  a  dataset 
USAGE 

RUN  SPCTRM 

Input  data  is  read  from  unit  11  or  12 
Output  is  to  unit  7  (default  TT  ?  ) 

INPUT  PARAMETERS 

IBKNR  -  PlocK  number  of  dataset 
NARRAY  -  Array  type  (1  if  n-6*  0  if  n-7 ) 

NREC  -  Number  of  records  < 3  or  4) 

NSMO  -  Number  of  smoothings 

NBELL  -  A  switch  <0  if  no  )  to  shape  data  with  cosine  bell 
NOP  -  Number  of  data  points  (must  be  a  power  of  2) 

NPRINT  -  Number  of  fre auency  estimates  to  be  output 
HREC  -  Missing  channel  ( 0 .  1 » 2» 3 *4 *5 *6  or  7) 

REMARKS 

Provision  is  made  in  this  program  for  the  future  expansion  of 
the  n-6  array  to  four  channels.  Uhen  this  is  done'  the  two 
statements  indicated  below  should  be  removed. 

LIBRARIES  REQUIRED 

antlib»sy:forlib 

METHOD 

The  data  is  transformed.  The  power  spectrum  for  each 
channel*  and  the  trace  spectrum  are  calculated.  These  are 
each  output*  along  with  the  corresponding  values  of 
freouency.  NEST  (as  used  in  the  offline  analysis  programs)' 
and  SE  (as  used  in  the  RTGAIU  program). 

COMMON  /DATPAS/  HATA( 51 2 » 4  ) »  FXI ( 51 2 . 4  ) . NOP . NSTRT . NARRAY » IREC 
COMMON  /IiETEK/  BETR(  50»50  )» IDIREC»  INULL 
COMMON  /SPEC/  SMATR( 256  )»SE(  256  ),NREC»NHALF'NSKO'FNOP 
DIMENSION  S( 300*4  )»ISE(  256  ) *FREQ(  256  >,TRACE(256  ) 

EQUIVALENCE  (  ISE(  1  )*SMATR(  1  )  )*(  S(  1*1  )*DETR<  1.1  )> 


Program  initialization  area 
TYPE  5 

5  FORMAT  ('  ENTER  IBKNR.NARRAY .NREC .NSMO. NBELL .NOP .NPRINT'  ) 
ACCEPT  10 . I BKNR . NARRAY . NREC .NSMO . NBELL . NOP » NPR I  NT 
10  FORMAT  (7110) 

IF  (NPRINT  ,EQ.  0)  NPRINT=45 
IF  (NOP  .EQ.  0)  N0F'=512 
IF  (NSMO  ,EQ.  0)  NSK0=3 
IF  (NREC  ,EG.  0)  NREC=4 
MREC=0 

IF  <  NREC  .EQ.  4  )  GO  TO  20 
TYPE  15 

15  FORMAT  ('  ENTER  MISSING  CHANNEL'  ) 

ACCEPT  10.MREC 


* 


uouu  uuoo  oooo 


f 


> 


» 


r 


NREC=MREC+1 

IF  (NARRAY  .EG.  1)  MREC=HREC-4 
NREC=4 
20  KREC=4 

C  The  following  two  statements  should  be  removed  when  the  n-6 

C  array  is  expanded  to  four  channels 

IF  (NARRAY  .EG.  1)  KREC=3 
IF  (NARRAY  .EG.  1)  NREC=4 
NHALF=N0F’/2 
SINT=  1 . 

IF  (NARRAY  .EG.  1)  SINT=.25 
IUNIT=1 1+NARRAY 
RAD=180./3. 141592 
FN0P=FL0AT( NOP  ) 

TOTIME=SINT*FNOP 
F2R0=1 ./TOTINE 

REAIi  (  I  UN  IT  )  ( (  DATA(  J  » IREC  )» J  =  1  .NOP  >» IREC=1  »KREC  ) 


Transform  to  frequency  domain 
IDIREC= 1 

DO  30  IREC=1,NREC 

IF  (IREC  .EG.  HREC)  GO  TO  30 
DO  25  1=1.512 

FXI( I. IREC  )=0. 

25  CONTINUE 

CALL  DC 
CALL  RAMP 

IF  (NBELL.NE.O)  CALL  HANW 
CALL  FFT 
30  CONTINUE 


Calculate  frequency  and  spectral  estimate 

DO  35  I=2.NHALF 
FEST=FLOAT(  1-1 ) 

SE(  I  )=TOTIME/FEST 
ISE(  I  )=IFIX(  SE<  I  ) ) 

FREQ( I  )=F2R0*FEST 
S<  I.MREC  )=0 . 

TRACE(  I  )=0 . 

35  CONTINUE 
ISE(  1  )=0 
FREG(  1  )=0. 

S<  I.MREC  )=0 . 

TRACE(  1  )*0. 


Calculate  power  spectrum  for  each  channel 

PMAX=-1.E+10 
PMIN=+1,E+10 
DO  45  IREC=1 »MREC 

IF  (IREC  .EG.  MREC )  GO  TO  45 
DO  40  1=1 .NHALF 

S< I . IREC  )=<  DATA(  I . IREC  >**2+FXI(  I » IREC  )**2  )*FZR0 
40  CONTINUE 

45  CONTINUE 


a 


oooo  oono 


50 


IBIREC=NHALF 
INULL=NREC 
HO  50  1=1 »NSH0 
CALL  SHOOT 
CONTINUE 


Calculate  trace  spectrum 

DO  60  IREC=1 »NREC 

IF  < IREC  .EQ.  HREC)  GO  TO  60 
PO  55  1=1 » NHALF 

TRACE<  I  )=TRACE(  I  >+S<  I » IREC  ) 

55  CONTINUE 

60  CONTINUE 

HO  65  1  =  1 »  NHALF 

IF  < PMAX.LT.TRACE< 1  )  >  PKAX=TRACE<  I  ) 
IF  <  PttAX .EQ * TRACEC I  )  >  MAX=I 
IF  ( PMIN»GT  .TRACE(  I  )  )  PMIN=TRACE< I  ) 
IF  < PNIN.EQ.TRACE< I  )  )  HIN=I 
65  CONTINUE 


Output  results 


» 


♦ 


WRITE  <7.70  )  IBKNR 

70  FORMAT< ' OSPECTRAL  CALCULATIONS  FOR  BLOCK  '.14) 

WRITE  (7.75)  NSHO. NBELL 

75  FORMAT <  5X . ' SPECTRUM  SMOOTHED' » 12 » '  TIKES »  WINDOW » ' . 12  ) 

WRITE  <7.30)  FHAX.FREQ<  HAX  )>PHIN*FREQ( KIN  ) 

80  FORMAT <  5X, ' MAXIMUM  POWER  t ' . 1PE10  .2 » '  AT  ' ,0PF6. 4.' HZ' »/» 

&  5X, 'MINIMUM  POWER:' .1PE1 0,2.'  AT  ' .0PF6 . 4 , ' HZ'  ) 

IF  (NARRAY  .EG.  0)  WRITE  <7 .85) 

85  FORMAT  <'  NEST' »T10 , ' FREQ' , T1 8. ' SE' .T25 . ' RTG' .T35. 

&  'ERE'  .T45. ' TER'  .T55.'R0S'  .T63. 'TRACE'  ) 

IF  (NARRAY  .EQ.  1)  WRITE  (7.90) 

90  FORMAT  <'  NEST' , T10 , ' FREQ' ,T 1 8 . ' SE' .T25 . ' RTG' ,T35, 

&  'AUR' ,T45» ' VEE'  »T55.'???' »T63. 'TRACE'  ) 

WRITE  (7.95)  <I.FREQ<  I  ).ISE<  I  ).S<  1.1  ).S<  I.2).S<  1.3). 

6  S< 1 .4  )»TRACE< I  )»I  =  1 .NPRINT  ) 

95  FORMAT < 14 , 0PF10 .5 » 15. 1 PE  10. 2.1 PE 10. 2.1  PE 10. 2.1 PE 10, 2. E10. 2) 

CALL  EXIT 
END 


♦ 


* 


» 


o  o  n  o 


» 


» 


t 


♦ 


♦ 


♦ 


» 


» 


C********************  SPEKT2  .FOR  **%*****%*t*****%*****X%tXtt%** 
C 

C  Date  of  revision:  6-NGV-82 

C 

PROGRAM  5PEKT2 


C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


PURPOSE 

To  perform  spectral  analysis  between  two  channels 
USAGE 

RUN  SPEKT2 

Input  data  is  read  front  unit.  11  or  12 
Output  is  to  unit  7  (default  TT t  ) 


INPUT  PARAMETERS 

IBKNR  -  BlocK  number  of  dataset 

IXCH  -  First  input  channel  (  0*  1 »  2 «  3  *  4  >  5»  6  or  7) 
IYCH  -  Second  input  channel  < 0 . 1 .2 * 3. 4 > 5. 6  or  7) 
NARRAY  -  Array  type  (1  if  n~6.  0  if  n-7 ) 

NSMO  -  Number  of  smoothings 
NBELL  -  A  switch  (0  if  no)  to  share  data 
NOP  -  Number  of  date  points  (must  be  a 

NPRINT  -  Number  of  freauency  estimates  to 


wi th  cosine  bell 
power  of  2 ) 
be  output 


REMARKS 

Provision  is  made  in  this  program  for  the  future  expansion 
the  n-6  array  to  four  channels*  When  this  is  done»  the 
indicated  statement  should  be  removed 


LIBRARIES  REQUIRED 
ANTLIB *  SY i FORLIB 


METHOD 

The  date  is  transformed.  The  power  spectrum  for-  each 
channel*  the  trace  spectrum*  the  coherency  spectrum*  end 
the  phase  spectrum  are  calculated.  These  ere  each  output* 
along  with  the  corresponding  values  of  freouency*  NEST  (as 
used  in  the  offline  analysis  programs)*  and  SE  (as  used  in 
the  RTGAIW  program). 


COMMON  /DATPAS/  PAT  A( 512.4 )*FXI(  512*4 ),  NOP  * N3TRT * NARRAY *  I  REG 
COMMON  /DETEK/  DETR< 50* 50 ) , IDIREC* INULL 
COMMON  /SPEC/  SMATR<  256  ),SE(  256  )* NREC , NHALF * NSMO . FNOP 
DIMENSION  S12R<  256  )*S12I(  256  )  *  FREQ(  256  )*TRACE(  256  ).Ci!AN<  S  ) 
DIMENSION  SI K 256  )*S22(  256  )  * COHXYC 256  ) * PHIXY( 256  ).I5E(  256  ) 
EQUIVALENCE  (S12R(  1  )*BETR<  1  *  1  ))*(S12I(  1  )*BETR(  1*7)) 
EQUIVALENCE  ( FREG( 1  )*DETR( 1*25  )  )*(TRACE(  I  ) * BETR<  1.31  )  ) 
EQUIVALENCE  (Slid  )*DETR<  1*  13)  )*(  S22(  1  ),DETR(  1*19)) 
EQUIVALENCE  (  C0HXY<  1  )*DETR(  1.37)  ),(PHIXY(  1  ) * BETR(  1.43)) 
EQUIVALENCE  ( ISE( 1  )*SMATR(  1  )  ) 

DATA  CHAN/3HRTG  *  3HERE  *  3HTER  *  3HR0S  *  3HRTG  »  3HAUR  *  3t!VCE  *  3HNL  W/ 


of 


Program  initialization  area 


> 


10 


TYPE  5 

F0RMAT( '  ENTER  IBKNR. IXCH* IYCH. NARRAY . NSMO. NBELL . NOP , NPR1 NV  ) 
ACCEPT  10 . IBKNR , IXCH. IYCH . NARRAY . NSMO . NBELL . NOP , NPRI NT 
FORMAT  (3110) 

IF  (  NPRINT,  EQ.O  )  NPF.'INT=45 


oooo  noon  oooo  oo 


IF  (NOP.EG.O)  N0F‘=51 2 
IF  (NSMO.EO.O)  NSM0~3 
SI NT= 1  , 

IXCH= IXCH+ 1 
IYCH=IYCH+1 
XCH=CHAN< IXCH  ) 

YCH=CHAN<  IYCH) 

KREC=4 

IUNIT=1HNARRAY 
NHALF- KOP/2 
RAD=180,/3. 141592 
FNOP=FL0AT< NOP ) 

TOTIME=SINT*FNOP 
FZR0=1 ./TOTIHE 
NREC=4 
IPIREC=1 

IF  (NARRAY.EQ.O  )  GO  TO  11 
SINT= .25 
IXCH=IXCH-4 
I YCH=I YCH-4 

The  following  statement  should  be  removed  when  the  n -6 

array  is  expanded  to  four-  channels 

KREC=3 

11  READ  (I  UNIT)  ( i HAT  A< J s IREC ) «  J=1 *  NOP ) » IREC=i »  KREC ) 


Transform  to  frequency  domain 

HO  15  IREC=1»NREC 

IF  <  IF:EC.EQ.  IXCH  )  GO  TO  12 
IF  < IREC. EQ. IYCH  )  GO  TO  12 
GO  TO  15 

12  PO  13  1=1. NOP 

FXI< I. IREC  )=0 . 

FXI  (  I » IREC  )=0  . 

13  CONTINUE 
CALL  I'C 
CALL  RAMP 

IF  (NBELL.NE.O)  CALL  HANW 
CALL  FFT 
15  CONTINUE 


Calculate  frequency  and  spectral  estimate 

HO  20  1=2. NHALF 
FEST=FLOAT< 1-1 ) 

SE( I  )=TOTIME/FEST 
ISE<  I  )=IFIX(  SE(  I  ) ) 

FREG< I >=FZR0*FEST 
20  CONTINUE 
I  SEC  1  >=0. 

FREG<  1  )=0 . 


Calculate  power  spectrum  for  each  channel 

PNORM=l ./<  SINT*FN0P  ) 

PHAX=-1 . E+l 0 
PHIN=  +  1  ,E+10 


DO  30  1  =  1 . NHALF 

f  Slid  >=<  DATAC  IiIXCH)**2+F)CI(  I .  IXCH  )**2  >*PNQkM 

S22( 1  )=< DATAC I » IYCH  )**2+FXlC 1  .IYCH  )**2  )#PNORM 
S12RC  I  >=BATAC  1  .IXCH  )*IiATAC  1 1  IYCH  HFXIC  I .  IXCH  )*FX2C  1 ,  I  VCH  ; 
S12I( I  )=FX I  C  I. IXCH  >*DATA( I. IYCH  >-UATAC I .IXCH  >*FXIC I. IYCH ) 
S12R<  I  >=S12F:C  I  )*PNQRM 
S12I( I  )=S1 2I( I >*PNOKM 
r  30  CONTINUE 

IF  CNSMO.EQ.O)  GO  TO  33 
IBIREC=NHALF 
INULL=NREC 
DO  35  1=1. NSNO 
CALL  SNOOT 

»  35  CONTINUE 

C . . . 

C 

C  Celculste  trsce.  coherency  end  ehese  seectruiiis 

C 

DO  40  1=1. NHALF 

•  TRACEC I  )=S1 1(1 1+S22C I  ) 

IF  <  PMAX  .LT . TRACEC I  ) )  PNAX=TRACE< I  ) 

IF  <  PNAX  .EQ . TRACE< I  )  >  NAX=I 

IF  <  PNIN.GT . TRACEC I > )  FMIN=TRACEC I  ) 

IF  C  F'MIN.EG.TRACEC  I  )  )  MIN=I 

COHXY(  I  )=C  S12RC  I  )#42!-S12IC  I  >*:»: 2  )/<  SI  1<  I  )*S22C  I  )  ) 

*  PHIXY( I  )=RAD4ATAN2(  S12IC  I  ).S12R(  I  )) 

40  CONTINUE 

C . . . 

C 

C  Outeut  results. 

C 

TYPE  45.IMNR 

FORNATC  'OSF’ECTRAL  CALCULATIONS  FOR  BLOCK  '.14) 

TYPE  50.NSN0.NBELL 

FORNATC 5X,' SPECTRUM  SMOOTHED' ,12.'  TINES.  WINDOW i ' . 12  ) 

TYPE  55 » PMAX » FREQC  MAX  I.PMIN. FREQC  Ml N  ) 

FORNATC  5X.' MAXIMUM  POWER! '  .  1F'E10.2.  '  AT  '  ,  0PF6 .  A  , '  H2 '  .  /  , 

5X, ' MINIMUM  POWER! ' , 1PE10.2.  '  AT  ' . 0FT6 . 4 . ' HZ '  ) 

TYPE  6Q.XCH.YCH 

FORMAT  C'  NEST' *T10» ' FREQ' »T1S» ' SE' . T25. A3*  T36. 

'COH'  »  T44  » '  F'HASE'  .  T53.  A3.  T63, '  TRACE'  ) 

WRITE  ( 7.65  )  < I  ,  FREQC I  l.ISEC I >9  SI  1C  I  l.COHXYC I  l.PHIXYC I  ), 

S22C I  ) , TRACEC 1  ). 1  =  1 .NPRINT  ) 

FORMATC 1 4 . OPF 1 0 . 5 . 1 5 . 1PE 1 0 . 2 . OPF 1 0 . 2 . F 1 0  *  2 . 1 PE  1 0 , 2 . E 1 0 , 2  ) 
CALL  EXIT 
END 


I 


SST£bLIBRARIAN  yo3 • 05  B6B  JgrJHE:|?  88*88*88 

M0I,ULE  GLOBALS  GLOBALS 


GLOBALS 


ASA 

BEAMFL 

DC 

FFT 

HANW 

LSORS 

RAMP 

SELECT 

SMOOT 

SPECTR 

XCORR 


c***************  ASA .  FOR  Xt*XXX*XX**XX*XXXXttX**X*Xt****t**tXt**XX**X 
C 

C  Date  of  revision:  25-Jul-82 

C 

SUBROUTINE  ASA 
C 

C  PURPOSE 

C  To  calculate  the  inner  product  of  a  vector  with  a  matrix 

C 

C  USAGE 

C  CALL  ASA 

C 

C  INPUT  PARAMETERS 

C  None 

C 

C  REMARKS 

C  None 

C 

C  SUBROUTINES  REQUIRED 

C  SMOOT 

C 

C  METHOD 

C  At  each  freouency.  each  element  of  the  spectral  matrix  is 

C  multelied  by  the  state  vector  according  to  the  equation 

C  D  =  <A  S  A>  /  Tr<S).  where  A  is  the  state  vector*  S  is  the 

C  spectral  matrix*  and  P  is  the  Quadratic  result* 

C 

COMMON  /DATPAS/  DATA<  51 2, 4  >.  FXI<  51 2. 4  >»  NOF,  IG.NARRAY ,  IREC 
COMMON  /DETEK/  PETR< 50 , 50 ) . 1PIREC * MREC 

COMMON  /SPEC/  PETECT <  256  )  *  TRACE! 256  )  *  NREC  *  NHALF  *  NSMO  *  FNOP 
PIMENSION  DUMRC  300  ). DUMI<  300  )*AR(  4  )*AI(  4  ) 

DIMENSION  DUM1<  300  )  »DUM2( 300  ) 

EQUIVALENCE  <DUM1<  1  )*DE TR<  1*13  >>*<PUM2<  1  >*UETR<  1*19>> 
EQUIVALENCE  <  DUMRC  1  ).BETR<  1.1)  ),<  PUMK  1  )*DETR(  1,7)) 

EQUIVALENCE  (  AR<  1  ).IlETR(  1.50  )  ),(  AI(  1  ).DETR<  5,50  )  ) 

C .  -  ♦ . . . ♦ . .  , 

C 

C  Routine  initialization  area 

C 

IREC=MREC 

IPIREC=NHALF 

MREC=2 

DO  5  J=  1  » NHALF 
PUMK  J  >=0. 

PUM2<  -.I  )=0. 

TRACEC  J  )=0. 

PETECT(  J  )=0  ♦ 

5  CONTINUE 

. . 

c 

0  For  each  element  of  spectral  matrix! 

C 

DO  60  1=1, NREC 

IF  < I  . EQ ,  IREC )  GO  TO  60 
DO  40  K=1 .NREC 

IF  <  K  .  EQ .  IREC)  GO  TO  40 
C 

C  Calculate  value  of  spectral  matrix  element 

C 

PO  10  4*1. NHALF 


non  no  o 


n 


10 


UUHR(  J  )=DATA<  J » I  )*IiATA<  J.K  HFXI<  J»I  )*FXI<J»K> 
DUNK  J  )»FXI(  J  *  I  )#DATA<  J  »K  )-DAT  A<  J » I  )*FXI<J»K) 
CONTINUE 
HO  20  J=1 i NSMO 
CALL  SNOOT 
CONTINUE 

F'remultiplv  by  state  vector 


HO  30  J  =  1 » NHAL.F 

HUNK  J  )=nUNl(  J  )+nUNR(.J  >*AR(  K  )-HUHI(  J  )*AI(  K  ) 
HUM2(  J  )*HUN2(  J  )+HUNR(  .J  )*AI<  K  HDUHH  J  >*AR<  K  ) 
IF  <  I  .EQ.K  )  TRACE<  J  )=TRACE<  J  >+DUMR<  J  ) 

30  CONTINUE 

40  CONTINUE 


Fostmu  1  tirly  by  state  vector 


HO  50  J=1 »NHALF 

HETECT<  .J  )=HETECT<  J  HDUHH  .J  )*AR<  1  HDUH2C  J  >*AI<  I  ) 
DUM1< J  )=0 . 

HUN2<  J  )=0. 

50  CONTINUE 

60  CONTINUE 

C.  . . . . 

C 

C  Normalize  result 

C 

HO  70  J=1 »NHALF 

DETECT (  J  >=HETECT<  J  )/TRACE(  .J  ) 

IF  (1Q.NE.O)  HETECT<  J  )=DETECT<  J  )**IG 
70  CONTINUE 
«REC=IREC 
RETURN 
ENH 


i 


oooo  onnn 


C****************  BEAMFL .FOR  5m*********>W***!«**********************#4 
C 

C  Dale  of  revision:  25-.Ju  1  -82 

C 

SUBROUTINE  BEAMFL 
C 

C  PURPOSE 

C  To  filter  s  multivariate  time  series  through  the  modulation 

C  of  the  time  series  transform  by  the  application  of  a 

C  beam-steering  algorithm 

C 

C  USAGE 

C  CALL  BEAMFL 

C 

C  INPUT  PARAMETERS 

C  None 

C 

C  REMARKS 

C  None 

C 

C  SUBROUTINES  REQUIRED 

C  ASA,  FFT 

C 

C  METHOD 

C  After  transforming  to  the  freouency  domain,  the  inner  product 

C  of  the  state  vector  with  the  spectral  matrix  is  calculated  at 

C  each  freouency,  which  is  then  multiplied  by  the  transform  of 

C  the  data.  The  filtered  data  is  then  transformed  back  to  the 

C  time  domain. 

C 

COMMON  /DATF'AS/  DAT A<  512,4  >,FXI<  512,4  ), NOP, NSTRT , NARRAY ,  IREC 
COMMON  /DETEK./  DETRC  50,50),  IDIREC  ,MREC 

COMMON  /SPEC/  SNATR<25<4  ),TRACE<  256  >,NREC,NHALF,NSNO,FNOP 


Transform  to  freouency  domain  and  calculate  inner  product 

NHALF 1=NHALF+1 
II<IREC=1 

DO  20  I REC= 1 , NREC 

IF  < IREC  .EQ,  NREC)  GO  TO  20 
DO  10  1=1, NOP 

FXI<  I, IREC  )=0. 

10  CONTINUE 

CALL  FFT 
20  CONTINUE 
CALL  ASA 


Impress  result  on  transformed  date 

SNATR< 1  )=0 . 

DO  50  1=1, NREC 

IF  < I  . EQ »  MREC )  GO  TO  50 
DO  30  4*1, NHALF 

DAT  A<  J » I  )=DATA(  J  *  I  >*SMATR<  J  ) 
FXI( J ,  I >=FXI<  J»I  )#SMATR< J  ) 

30  CONTINUE 

DO  40  J=2, NHALF 
J J=N0P-J+2 


) 


noon 


DATA<  JJ  *  I  )=DATA<  J  J  f  I  >*SNATR<  J  ) 
FXI(  Jjf I  )=FXI<  JJ  » I  )#SHATR<  J  ) 

40  CONTINUE 

DATA<  NHALF 1 1 1  )=DATA<  NHALF  1 1  ) 

FXI(  NHALF  1  f  I  )=0. 

50  CONTINUE 


Transform  to  time  domain 

IDIREC=-1 

HO  70  IREC=1 *NREC 

IF  < IREC  .ER.  NREC)  GO  TO  70 
DO  60  J=ltN0P 

DATA<  .J»  IREC  )=DATA(  J  .  IREC  >7FNOP 
FXI<  J » IREC  )=FXI<  J  » IREC  )/FN0P 
60  CONTINUE 

CALL  FFT 
70  CONTINUE 
RETURN 
END 


ooonoonoonooooorjoooo  o  n  o 


To  remove  the  ever age  value  from  a  data  string 

USAGE 

CALL  DC 

INPUT  PARAMETERS 
None 

REMARKS 

None 

SUBROUTINES  REQUIRED 
None 

METHOD 

The  average  value  of  the  data  string  is  calculated  and 
subtracted  from  each  data  *oint. 

COMMON  /DATPAS/  DAT A< 512*4  )*FXI<  512*4  >*  NOP*  NSTF.'T »NARRAY *  IREC 
FNOP=FLOAT<  NOP  ) 

At'E=0. 

DO  10  1=1* NOP 

AUE=AVE+DATA<  I  *  IREC  ) 

10  CONTINUE 

AVE=AUE/FNOP 
DO  20  1  =  1  *  NOP 

DAT  A(  I  » IREC  )=HATA<  I » IREC  )-AUE 
20  CONTINUE 
END 


» 


I 


t 


C****************  FFT ♦ FOR 
C 

C  lisle  of  revision! 

C 


C 


SUBROUTINE  FFT 


*  it  *  *  *  *  *  *  *  *  *  *  #  *  *  *  *  *  *  #  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  #:  *  #  *  * 
25- Ju 1-82 


C  PURPOSE 

C  To  perform  the  forward  or  inverse  Fourier  transform 

C 

0  USAGE 

C  CALL  FFT 

C  IIiIREC  must  be  +1  for  forward  transform*  or  -1  for  inverse. 

C 

C  INPUT  PARAMETERS 

C  None 

C 

C:  REMARKS 

C  The  number  of  points  in  the  data  string  must  be  a  power  of  2. 

C  The  input  data  string  is  lost  in  the  transform  process. 

C  When  performing  the  inverse  transform*  the  input  data  should 

C  first  be  normalised  by  the  number  of  points. 

C 

C  SUBROUTINES  REQUIRED 

C  None 

C 

C  METHOD 

C-  A  simple  fast  Fourier  transform  performing  a  "shuffle"  followed 

C  by  a  "butterfly."  See  "The  Fast  Fourier  Transform"  by  Brigham 

C  for  more  information . 

C 

DIMENSION  INIK  512  >,  ST<  512  >*CT<  512  ) 

COMMON  /HA TP AS/  PATA<512,4  ),FXI<  512.4  )  *  NOP . NSTRT * NARRAY . I REC 
COMMON  /PETEK/  DETR<  50  *  50  ) .  IIUREC,  INULL 

COMMON  /SPEC/  SMATR<  256  )  ,  TRACE! 256  ) . NREC  *  NHALF  *  NSMO » FNOP 
EQUIVALENCE  <  CTC  1  ) » HETR<  1,1  )),<ST<  1  ),DETR<  1,12)) 

EQUIVALENCE  <  INIK  1  )*HETR<  1,23)) 

C . . . . . .  . . 

C 

C  Program  initialization  ares 

C 

DIREC=FLOATt  IIUREC  ) 

0MEG=-3. 14159/FNOP 
DO  5  1=1, NOP 

ARG=FL0AT(  1-1  )*0MEG 
ST <  I  )=SIN<  ARG  ) 

CT< I  )  =  C0S<  ARG  ) 

INIK  I  )=I 

FXI (  I , IREC  )=FXI <  I , IREC >*DIREC 
5  CONTINUE 

C . . . . . . . . 

c 

C  Shuffle 

C 

J=1 

DO  35  1=1, NOP 

IF  ( I-J  )  10,15, 15 
10  IT  =  INIK.J) 

INIK  J  )=  I  NIK  I  ) 

INIK  I  )=  IT 
N=NHALF 


15 


noon  noon 


20 

IF  <  J-M  )  30,30,25 

25 

J=J-N 

M=<  M+l  )/2 

GO  TO  20 

30 

J  =  J  +  N 

35 

CONTINUE 

Bu  tterf lv 
MAX=  1 

40  IF  (NAX-NOP)  45,60.60 
45  1STEP=2*HAX 

NSTEP=N0P/NAX 
U0  55  H=1,MAX 

K=<  H-l  >*NSTEP+1 
SS=ST( K ) 

CC=CT<  K ) 

BO  50  I=M  »N0P , ISTEP 
J=I+MAX 

TR=CC*DATA<  I  NIK  J  ),IREC  )-SS*FXI<  INIK  J  >,IREC  > 
T1=CC*FXI<  INIK  J  ),  IREC  )+SS*DATA<  INIK  J  ),  IREC  ) 
DAT A<  INIK  .J  ),  IREC  )=DATA(  INIK  1  ),  IREC  >-TR 
DAT A<  INIK  I  ) ,  I REC  )=DATA<  INIK  I  >,IREC  >+TR 
FX3 (  INIK  J  ),  IREC  )=FX1<  INIK  I  ),IREC  )-TI 
FXI(  INIK  I  ),  IREC  >=FXI<  INIK  I  >,IREC  HTI 
50  CONTINUE 

55  CONTINUE 
NAX=  I  STEP 
GO  TO  40 


Output  reshuffle 


60  DO  65  1=1, NOP 

ST <  INIK  I  )  )=DATA<  I ,  IREC  ) 
CT<  INIK  I  ))=FX1(  I,  IREC  ) 
65  CONTINUE 

DO  70  1=1, NOP 

DATA(  I,  IREC  )=ST  <  I  ) 

FXI<  I ,  IREC  )=CT<  I  ) 

70  CONTINUE 
RETURN 
END 


onoo  nonn 


C****************  FFT .  FOR  #)»;*!*:**».)»:***!»:)»:<c**:***:)M:*****  :M:**J»uK:Mtf***** 

C 

SUBROUTINE  FFT<  IIlIREC  ) 

C  V 

C  Bate  of  revision:  19-.Jul-82  <M,4-  “"ih  T'*-r'L) 

C 

C  PURPOSE 

C  To  perform  the  forward  or  inverse  Fourier  transform 

C 

C  USAGE 

C  CALL  FFT<  IHIREC) 

C 

C  INPUT  PARAMETERS 

C  IBIREC  -  Direction  of  transform:  +1  if  forward*  -1  if  inverse 

C 

C  REMARKS 

C  The  number  of  points  in  the  data  string  must  be  a  power  of  2. 

C  The  input  data  string  is  lost  in  the  transform  process. 

C  When  performing  the  inverse  transform*  the  input  data  should 

C  first  be  normalized  by  the  number  of  points. 

C 

C  SUBROUTINES  REQUIRED 

C  None 

C 

C  METHOD 

C  A  simple  fast  fourier  transform  performing  a  "shuffle"  followed 

C  by  a  "butterfly.”  See  "The  Fast  Fourier  Transform"  by  Brigham 

C  for  more  information. 

C 

DIMENSION  I  NIK  512 >*ST(  512 >*CT(  512 > 

COMMON  /BATPAS/  DATA< 512 .4  ) ,FXI< 512 *4  ), NOP .NSTRT .NARRAY , IREC 
COMMON  /BETEK/  DUMMY< 256*4) 

COMMON  /SPEC/  SMATR<  256  )  »TRACE<  256  )  *NREC*NHALF , NSNO  *FNOP 
EQUIVALENCE  (  CT<  1).DUMMY(1»1  )>*<ST<1  )*DUMMY<  1.3)) 


Program  ini tial ization  area 

DIREC=FLOAT (  IDIREC) 

0MEG=-3. 14159/FNOP 
DO  5  la  1* NOP 

ARG=FLOAT< 1-1 )*OMEG 
ST<  I  )=SIN<  ARG  ) 

CT< I  )=COS<  ARG  ) 

I  NIK  I  )=I 

FXI(  I* IREC  )=FXI< I. IREC )*DIREC 
5  CONTINUE 


Shuffle 


J*1 

DO  35  1=1. NOP 


IF  < 1-J  )  10*15*15 

10 

I T = I  NIK  J  ) 

I  NIK  J  )=INIK  I  ) 

I NIK  I  )=IT 

15 

M=NHALF 

20 

IF  <  J-M )  30,30*25 

25 

J= J-M 

H=( M+l  )/2 
GO  TO  20 
30  J=.J+N 

35  CONTINUE 

C . . 

c 

C  Butterfly 

C 

MAX=  1 

40  IF  <  NAX-NOP  )  45,60,60 

45  ISTEP=2*MAX 

N3TEP=N0P/NAX 
HO  55  M=1 »NAX 

K=<  M-l  XNSTEP+l 
SS=ST(  K  ) 

CC=CT(  K  ) 

BO  50  I=H»NOP * ISTEP 
J=I+NAX 

TR=CC*PATA<  INB<  J  >,IREC  >-SS*FXI<  INIK  J  >*IREC  ) 
TI=CC*FXI<  INIK  J  )» IREC  >+SS#HATA<  INP<  J  ),  IREC  > 
BATA'.  INB(  J  ),  IREC  >=BATA<  INIK  I  >,  IREC  )-TR 
BAT A<  INIK  I  )» IREC  )=BAT A<  INIK  I  It  IREC  HTR 
FXI<  INIK  .J  )  >  IREC  )=FXI(  INIK  I  ).IREC  )-TI 
FXI<  INIK  I  )f  IREC  )=FXI<  INIK  I  ).IREC  >+TI 
50  CONTINUE 

55  CONTINUE 
MAX=ISTEP 
GO  TO  40 

C.  . . . 

C 

C  Output  reshuffle 

C 

60  no  65  1  =  1 » NOP 

ST  (  INIK  I  >)=PATA<  I  ,  IREC) 

CT<  INIK  I  )  )=FXI<  I  *  IREC  ) 

65  CONTINUE 

PO  70  1=1, NOP 

PAT A<  I » IREC  )=ST( I  ) 

FXI<  1 1  IREC  )=CT(  I  ) 

70  CONTINUE 
RETURN 
ENIi 


o  o  o  o  n  r?  o 


C*****************  HANW  .FOR 

Dele  of  revision?  20-Aer-82 
SUBROUTINE  HANW 
PURPOSE 

To  shape  s  dels  string  with  s  Hanning  (cosine  bell)  window 

C  USAGE 

C  CALL  HANW 

C 

C  INPUT  PARAMETERS 

C  None 

f  C 

C  REMARKS 

C  None 

C 

C  SUBROUTINES  REQUIRED 

C  None 

♦  C 

C  METHOD 

C  Each  data  point  is  multiplied  by  <1  +  eos(  ARC  )  >  where  ARG  is 

C  determined  by  that  data  point's  position  in  the  data  string 

C 

COMMON  /DATPAS/  DAT A<  512.4  )»FXI<  512.4  ).  NOF'r  NBTRT .NARRAY .  IREC 
►  PI=3. 141592 

FNOP=FLOAT< NOP  ) 

HO  10  1=1. NOP 
X=FL0AT<  I  ) 

ARG=( X-FNOP/2 . )/<FNOP/2.  ) 

DAT A(  I .  IREC  )=DATA(  I ,  IREC  >*(  1  .+C0S(  PI*ARG  )  >/2  . 

9  10  CONTINUE 

RETURN 
END 


t 


t 


C *************  LSQRS.FOR  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 

C 

C  Iiste  of  revision:  20-May-82 

C 

SUBROUTINE  LSQRS 
C 

C  PURPOSE 

C  A  system  optimized  version  of  3  least-sauares  procedure  for 

C  the  direct  estimation  of  azimuth  and  velocity  of  a  propagating 

C  wave.  (FI inn  &  McCowan *  1970) 

C 

C  USAGE 

C  CALL  LSQRS 

C 

C  INPUT  PARAMETERS 

C  None 

C 

C  REMARKS 

C  This  routine  is  an  adaption  of  BEMEST  for  use  with  the  ANTURK 

C  routines.  BEMEST  was  written  by  It.  Spell  for  use  with  the 

C  RTGAIW  system.  XI*IF»  YD1F*  TBIF  are  differences  between  pairs 

C  of  an  array.  The  differences  are  ordered  l-2*l-3*2-3  on 

C  the  T  array  and  l-2» l-3» l-4*2~3*2-4*3-4  on  the  F  array.  n.b. 

C  When  the  F  array  only  has  three  channels*  the  caller  must 

C  arrange  the  channel  dimensions  to  conform. 

C 

C  SUBROUTINES  REQUIRED 

C  None 

C 

C  METHOD 

C  Compute  the  generalized  inverse  matrix  of  station  separations. 

C  This  reouires  the  "left-inverse"  of  the  non-symmetr ic  matrix 

C  I H  3  *  given  byJ  <  1/CH3'  CH3  )CH3'  where  CHD'  is  the  conjugate 

C  transpose  of  EH3. 

C 

COMMON  / AZIMUT/  A2IMF  * VELDC * AZVAR » VEVAR 

COMMON  /CORPAS/  THIF<  6  )»RH0<  6 >*XDIF<  6  >*  YDIF( 6  )* INRDIF,MREC 
DATA  RADDEG/57, 29578/ 

C . . . 

c 

C  Routine  initialization  area 

C 

13  XBYX  =  0. 

YBYY  =  0. 

TBYT  =  0. 

XBYY  =  0. 

XBYT  =  0. 

YBYT  =  0. 

DO  15*1  =  1 » INRDIF 
XBYX  =  XBYX  4  XDIF< I  )**2 
YBYY  =  YBYY  4  YDIF< I  )**2 
TBYT  =  TBYT  4  TIUF<  I  )**2 
XBYY  =  XBYY  4  XDIF< I  )tYPIF< I  ) 

XBYT  =  XBYT  4  XDIF< I  )*TB3F< I  ) 

15  YBYT  =  YBYT  4  YD1F< I  )*TPIF< I  ) 

C . . . . . 

C 

C  Find  azimuth  (degrees)  and  velocity  (meters/second). 

C 

DET  =  1 . /( XBYXtYBYY  -  XBYY**2 > 


FI  =  <  YBYYfcXBYT  -  XBYY*YBYT  )*BET 
F2  *  (XBYX*YBYT  -  XBYY*XBYT  )*HET 
THETA  =  ATAN2<  F1»F2 ) 

HENOH  =  SQRT(F1**2  +  F2**2  ) 

IF  (  HENOH  .EQ.  0. )  GO  TO  22 

VELOC  =  1. /HENOH 
A2IHF  =  THETA*RAHHEG 

IF  ( A2IHF  .LT.  0.)  A2IHF  =  A2IHF  +  360. 

F1F1  s=  F1*F1 
F1F2  =  F1*F2 
F2F2  =  F 2*F2 
V2  =  VEL0C**2 
04  ~  VEL0C#*4 
FBY1  =  F1F1*XBYX 
FBY2  =  F2F2CYBYY 
FBY3  =  -F1F2*XBYY 
FBY4  =  F1F1*YBYY 
FBY5  =  F2F2*X8YX 

TERRSQ  =  ABS<  TBYT  -  FBY 1  -  FBY2  +  2*FBY3 > 

XONE  =  TERRSQ*V4*BET 

VEVAR  =  SQRT<V2*X0NE*< FBY4  +  FBY5  +  2CFBY3 )  ) 
A2VAR  =  SQRT(X0NE*(FBY2  4  FBY1  -  2*FBY3  )  )*RADHEG 

IF  (INRDIF  .EQ.  3)  GO  TO  22 
VEVAR  =  .25*VEVAR 
A2VAR  =  .  254A2VAF: 


RETURN 

END 


C3U****************  RAMP. FOR  *t*XXtX*t*****t**t.****X**X*t******%***X* 

C 

C  Dele  of  revision  l  20- Apr -82 

C 

SUBROUTINE  RAMP 
C 

C  PURPOSE 

C  To  remove  the  linear  trend  from  a  data  string 

C 

C  USAGE 

C  CALL  RAMP 

C 

C  INPUT  PARAMETERS 

C  None 

C 

C  REMARKS 

C  None 

C 

C.:  SUBROUTINES  REQUIRED 

C  None 

C 

C;  METHOD 

C  The  straight  line  thst  best  approximates  the  date  string  is 

C  calculated  using  a  least-souares  approach.  and  then  subtracted 

C  from  the  data  string. 

C 

COMMON  /DAT F' AS/  BAT  A<  512.  A  > *  FXI <  512 . 4  >» NOP,  NSTRT  » NARRAY ,  IREC 
SAX=0. 

SA=0. 

SX=0. 

SXX=0. 

FNOP=FLOAT<  NOF ) 

DO  10  1  =  1.  NOP 
X=FL0AT< I  ) 

SAX=SAX+DATA( I . IREC  >*X 
SA=SA*DATA<  I » IREC ) 

SX=SX+X 
SXX=SXX+X*X 
10  CONTINUE 

RM=< SAX*FNOP-SA*SX )/<  SXX*FN0P-SX#*2 ) 

C=SA-RM*SX 
C=C/FN0P 
DO  20  1=1. NOP 
X=FL0AT< I  ) 

DAT A<  I » IREC  )=BATA(  I .  IREC  >-RM*X-C 
20  CONTINUE 
RETURN 
END 


onnoorjoooooooocioacjo  ooo 


C#*)U***)U***********  SELECT  .FOR  ***MtX*.***tX*t*tt*******tt***t*** 
Pete  of  revision?  9-Pec-81 
SUBROUTINE  SELECT 
PURPOSE 

To  select  s  portion  of  s  data  string 
USAGE 

CALL  SELECT 

INPUT  PARAMETERS 
None 

REMARKS 
None 

SUBROUTINES  REQUIRED 
None 

METHOD 

NOP  points  starting  at  NSTRT  are  selected  from  the  data  strin 

COMMON  /DATPAS/  DAT A< 512,4  >»FXI<  512,4 >» NOP, NSTRT ,NARRAY, IREC 
DO  10  1=1, NOP 
L=NSTRT+I-1 

DAT A<  I ,  IREC  )=PATA<  L  ,  IREC  ) 

10  CONTINUE 
RETURN 
END 


nooonooooooooooooooo 


C***JU#**JU********  SMOOT  .FOR  *)U*****J«**************«*****>U***)U* 
C 

C  lisle  of  revision:  l-Oet-82 

C 

SUBROUTINE  SMOOT 
PURPOSE 

To  perform  s  three  point  smoothing 
USAGE 

CALL  SMOOT 

INPUT  PARAMETERS 
None 

REMARKS 
None 

SUBROUTINES  REQUIRED 
None 

METHOD 

The  value  of  each  point  is  added  to  half  the  value  of  each 
adjacent  point*  the  sum  being  then  normalized. 

COMMON  /DETEK/  DETR<  50.50).  NOP  .  NREC 
DIMENSION  DUMMY t  300 »  8 ) 

EQUIVALENCE  <  BUMMYt 1.1  >.DETR(1*1  )> 

NM1=N0P-1 
NM2=NM1-1 
DO  20  K=1  .NREC 
TEMP1=0. 

TEMP2-< DUMMY 1 1 ,K )+DUMMY(  2»K ) >/2. 

TEMP3=<  DUMMYC NOP . K  )+DUMMY<  NM1 . K  > )/2 . 

DO  10  1=2. NM1 
J  =  I-2 

IF  <  J . GT . 0  )  DUMMY< J.K  )=TEMP1 
TEMP1=TEMP2 

TEMP2=( DUMMYC I .K >+(PUMMY(  I - 1 . K )+DUMMY(  1+1 »  K ) >/2 , )/2. 

10  CONTINUE 

DUNMYt NM2.K  )=TENP1 
DUMMY <  NM1 . K )=TEMP2 
DUMMY ( NOP . K  )=TEMP3 
20  CONTINUE 
RETURN 
END 


oooo  noon  o  oonn 


1 

C********************  SPECTR  .FOR  ******************************* 

C 

C  lisle  of  revision  l  25-Jul-82 

C 

SUBROUTINE  SPECTR 
C 

C  PURPOSE 

C  To  cslculsle  the  Irsce  spectrum 

C 

C  USAGE 

C  CALL  SPECTR 

C 

C  INPUT  PARAMETERS 

C  None 

C 

C  REMARKS 

C  The  time  series  dsts  is  replaced  with  its  Fourier  transform 

C 

C  SUBROUTINES  REQUIRED 

C  DC, RAMP, FFT, SMOOT 

C 

C  METHOD 

C  The  average  and  linear  trends  are  removed  from  the  time  series 

C  data  before  transforming  to  the  freouencw  domain.  The  diagonal 

C  terms  of  the  spectral  matrix  are  calculated  and  summed. 

C 

COMMON  /BATPAS/  BATA< 512,4),  FXI< 512 . 4  ) , NOP , MREC , NARRAY , IREC 
COMMON  /DETEK/  BETR< 50 , 50 ) , IBIREC, I NULL 

COMMON  /SPEC/  SMATR<  25A  ) , TRACEt  256  )  *NREC , NHALF , NSMO , FNOP 
DIMENSION  S<  300,4 ) 

EQUIVALENCE  <S< 1,1  ).DETR< 1,1 >> 


Initialize  subroutine  end  transform  data 

IBIREC=1 
SINT= 1 . 

IF  (NARRAY.EQ.l  )  SINT=,25 
FZR0= 1 ♦ /( SINTCFNOP ) 

DO  15  IREC=1 »NREC 
DO  12  1=1, NOP 

FXI<  I ,  IREC  )=0  . 

12  CONTINUE 

CALL  DC 
CALL  RAMP 
CALL  FFT 
15  CONTINUE 


Calculate  freouencw  estimates 

DO  20  I =2 » NHALF 

SNATR< I  )*FZR0*FL0AT< 1-1 ) 

20  CONTINUE 

SMATR<  1  >=0 . 


Calculate  trace 


i 


DO  30  1=1 >NHALF 

HO  25  IREC= 1 »NREC 

S(  I » IREC  )=DATA(  1  *  IREC  >**2+FXI<  I .  IREC  >**2 
25  CONTINUE 

30  CONTINUE 

IF  (NSNO.EQ.O)  GO  TO  35 
IDIREC=NHALF 
INULL=NREC 
DO  35  1=1 *  NSNO 
CALL  SNOOT 
35  CONTINUE 

DO  45  1=1 » NHALF 
TRACE  <  I  >=0. 

DO  40  IREC=1.NREC 

IF  (IREC  .EG*  NREC  )  GO  TO  40 
TRACE<  I  )=TRACE(  I  HS<  I » IREC  ) 

40  CONTINUE 

45  CONTINUE 
RETURN 
END 


non  noon  oooo 


CXXXXXXX***************  XCORR  ♦  FOR 
C 

C  Date  of  revision!  25-Jul-82 

C 

SUBROUTINE  XCORR 
C 

C  PURPOSE 

C  To  calculate  the  cross-correlations  and  time  lass  between 

C  all  station  rains  in  a  3  or  4  channel  swstem 

C 

C  USAGE 

C  CALL  XCORR 

C 

C  INPUT  PARAMETERS 

C  None 

C 

C  REMARKS 

C  None 

C 

C  SUBROUTINES  REQUIRED 

C  None 

C 

C  METHOD 

C  The  cross-correlation  between  two  data  strings  is  calculated 

C  from  -32  to  +32  points  lag.  The  maximum  value  and  the  time 

C  lag  associated  with  it  are  then  returned  to  the  main  program 

C 

COMMON  /CORPAS/  DEl.T<  6  )»  CORR<  6  >»  DELX<  6  ),  DEL  Y<  6  ) »  NOSP » MREC 
COMMON  /DATPAS/  DAT A< 512 .4  ) t FXI< 512 .4  ) » NOP » NSTRT . NARRAY . IREC 
DIMENSION  H(65  ).J<  65  ) 

EQUIVALENCE  (  H<  1  >.FXI<  1 .2 )).<  J<  1  >»FXI<  1.1)) 


Routine  initialization  area 

N0S=3 

N0S1=N0S+1 

NEG=-1 

N=0 


Start  loops  for  station  pairs 

DO  50  IX= 1 . NOS 

IF  < IX  .EQ.  MREC  )  GO  TO  50 
KY= IX+1 

DO  40  IY=KY  » NOS  1 

IF  ( IY  .EQ.  MREC )  GO  TO  40 
N=N+1 

Calculate  normalization  factor 


XSQ=0. 

YSQ=0. 

DO  10  1*1. NOP 

XSQ=XSQ+DATA< I . IX  )**2 
YSQ*YSQ+DATA< I . IY  >**2 
10  CONTINUE 

HNORM*SQRT< XSQtYSQ  > 


i 


c 

\  »  c 


> 


20 

♦ 

30 

C 

C 

C 


40 

50 


t 


Calculate  cross-correlation  for  each  value  of  las 
MUM- 1 

DO  30  1=1 »65 
J<  1  )=l-33 
H<  1  )=0 . 

DO  20  K=1 » NOP 
L=K+J<  1  ) 

IF< < L.LE.O  ).0R.< L.GT .NOP >  )G0  TO  20 
HM=DATA<  L » IX  )*DATA<  N>IY ) 

H<  I  )=H<  I  )+HM 
CONTINUE 
H<  I  )=H<  I  >/HN0RM 
IF  (  H<  I  )  .QE  .  H<  NUM  )  >  NUH=I 
CONTINUE 

Determine  ftaximum  values 

CORR(  N  >=H<  NUM  > 

DELT<  N  )=FL0AT< NEG*J<  NUM  )  ) 

IF  < NARRAY . EQ. 1  )  DELT<  N  )=DELT<  N  >/4 ♦ 

CONTINUE 

CONTINUE 

RETURN 

END 
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